Sortare + copiere

Ce este nou in Microsoft Excel 2019?
Informatii despre cum se utilizeaza Microsoft Excel 2019
Calcule, Formule, Functii, Tabele pivot, Analiza datelor, etc
phanter_gl
Mesaje: 33
Membru din: Mar Feb 14, 2012 8:47 pm

Sortare + copiere

Mesaj de phanter_gl » Sâm Oct 23, 2021 3:44 pm

As dori o solutie , VBA preferabil , pentru a copia doar randurile aflate intre B4:G22 care sa contina pe coloanele D SAU F cuvantul aflat in celula D2 , in celulele aflate intre J4:O22 , fara spatii intre randuri.
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.

IPP
Moderator
Moderator
Mesaje: 4196
Membru din: Mie Iul 29, 2009 7:26 am
Localitate: Cluj-Napoca

Re: Sortare + copiere

Mesaj de IPP » Sâm Oct 23, 2021 5:12 pm

Buna ziua

Atasat aveti spre testare un fisier cu o propunere folosind macro.

Premise: nu modificati structura datelor si aveti grija sa nu fie informatie in zona J23:O32
Atentie, aveti spatii goale dupa informatia din D6, D12 si D22. In principiu am rezolvat din macro situatiile create dar ar fi bine sa aveti grija la ce fel de informatie folositi e posibil, sa nu functioneze cum trebuie daca veti introduce alt tip de informatie neconforma.

Am folosit urmatorul cod:

Cod: Selectaţi tot

Sub CustomCopy()

'IPP - 23.10.2021

Dim cCrt As Range

Sheets("Sheet1").Select
 Set cCrt = Range("D2")

 If cCrt = "" Then
  MsgBox "Trebuie sa alegeti un nume din lista", vbInformation, "Lipsa criteriu"
  cCrt.Select
  Exit Sub
 End If
 
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
  
 'sterge eventuala info veche
 Range("J4:O22").ClearContents
 
 For Each c In Range("D4:D22")
  If Trim(c) = cCrt Or Trim(c.Offset(0, 1)) = cCrt Then
   With Range("L30").End(xlUp).Offset(1, 0)
   .Value = c.Value
   .Offset(0, -2) = c.Offset(0, -2)
   .Offset(0, -1) = c.Offset(0, -1)
   .Offset(0, 1) = c.Offset(0, 1)
   .Offset(0, 2) = c.Offset(0, 2)
   .Offset(0, 3) = c.Offset(0, 3)
   End With
  End If
 Next c
 
  Application.Calculation = xlCalculationAutomatic
 Application.ScreenUpdating = True

End Sub
Pentru testare: deschideti fisierul atasat, activati macro/continutul, alegeti denumirea din lista si rulati macro apasand butonul albastru sau folosind alta metoda

IP
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.

phanter_gl
Mesaje: 33
Membru din: Mar Feb 14, 2012 8:47 pm

Re: Sortare + copiere

Mesaj de phanter_gl » Sâm Oct 23, 2021 6:24 pm

Mulțumesc pentru răspuns.
Am încercat și funcționează impecabil.

phanter_gl
Mesaje: 33
Membru din: Mar Feb 14, 2012 8:47 pm

Re: Sortare + copiere

Mesaj de phanter_gl » Sâm Oct 23, 2021 6:55 pm

Exista o posibilitate ca la selectarea din DROP LIST a unui oras sa nu mai fie nevoie de a da click pe butonul albastru , iar VBA-ul sa functioneze automat ?
Functioneaza perfect si asa dar as vrea sa trec peste o operatie ( apasarea butonului )

Tibi_Tiby
Mesaje: 34
Membru din: Lun Mar 09, 2020 4:12 pm

Re: Sortare + copiere

Mesaj de Tibi_Tiby » Sâm Oct 23, 2021 11:48 pm

Foloseste codul lui IPP intrun change event in D2

IPP
Moderator
Moderator
Mesaje: 4196
Membru din: Mie Iul 29, 2009 7:26 am
Localitate: Cluj-Napoca

Re: Sortare + copiere

Mesaj de IPP » Dum Oct 24, 2021 7:23 am

Buna ziua

Testati fisierul atasat in care am folosit (care, atentie, nu este intr-un modul ci la nivel de Sheet1) codul:

Cod: Selectaţi tot

Private Sub Worksheet_Change(ByVal Target As Range)

'IPP - 24.10.2021

Dim cCrt As Range
 Set cCrt = Range("D2")
 
If Not Intersect(cCrt, Target) Is Nothing Then

 If cCrt = "" Then
  MsgBox "Trebuie sa alegeti un nume din lista", vbInformation, "Lipsa criteriu"
  cCrt.Select
  Exit Sub
 End If
 
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Application.Calculation = xlCalculationManual
  
 'sterge eventuala info veche
 Range("J4:O22").ClearContents
 
 For Each c In Range("D4:D22")
  If Trim(c) = cCrt Or Trim(c.Offset(0, 1)) = cCrt Then
   With Range("L30").End(xlUp).Offset(1, 0)
   .Value = c.Value
   .Offset(0, -2) = c.Offset(0, -2)
   .Offset(0, -1) = c.Offset(0, -1)
   .Offset(0, 1) = c.Offset(0, 1)
   .Offset(0, 2) = c.Offset(0, 2)
   .Offset(0, 3) = c.Offset(0, 3)
   End With
  End If
 Next c
 
End If
 
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
IP
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.

phanter_gl
Mesaje: 33
Membru din: Mar Feb 14, 2012 8:47 pm

Re: Sortare + copiere

Mesaj de phanter_gl » Dum Oct 24, 2021 7:31 am

Tibi_Tiby scrie:
Sâm Oct 23, 2021 11:48 pm
Foloseste codul lui IPP intrun change event in D2
Mulțumesc pentru răspuns.
Am găsit ceva change event urmează doar să-l adaptez.

phanter_gl
Mesaje: 33
Membru din: Mar Feb 14, 2012 8:47 pm

Re: Sortare + copiere

Mesaj de phanter_gl » Dum Oct 24, 2021 7:40 am

Este perfect IPP ,
MUltumesc.

Tibi_Tiby
Mesaje: 34
Membru din: Lun Mar 09, 2020 4:12 pm

Re: Sortare + copiere

Mesaj de Tibi_Tiby » Dum Oct 24, 2021 8:48 am

phanter_gl scrie:
Dum Oct 24, 2021 7:31 am
Tibi_Tiby scrie:
Sâm Oct 23, 2021 11:48 pm
Foloseste codul lui IPP intrun change event in D2
Mulțumesc pentru răspuns.
Am găsit ceva change event urmează doar să-l adaptez.
Eu ma gandisem la ceva de genul

Cod: Selectaţi tot

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("D2")) Is Nothing Then
          CustomCopy
    End If
End Sub

phanter_gl
Mesaje: 33
Membru din: Mar Feb 14, 2012 8:47 pm

Re: Sortare + copiere

Mesaj de phanter_gl » Dum Oct 24, 2021 9:18 am

Functioneaza si aceasta solutie.
Multumesc

Scrie răspuns

Înapoi la “Intrebari despre Excel 2019”