Sortare + copiere
-
- Mesaje: 33
- Membru din: Mar Feb 14, 2012 8:47 pm
Sortare + copiere
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.
Re: Sortare + copiere
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:
Pentru testare: deschideti fisierul atasat, activati macro/continutul, alegeti denumirea din lista si rulati macro apasand butonul albastru sau folosind alta metoda
IP
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
IP
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.
-
- Mesaje: 33
- Membru din: Mar Feb 14, 2012 8:47 pm
Re: Sortare + copiere
Mulțumesc pentru răspuns.
Am încercat și funcționează impecabil.
Am încercat și funcționează impecabil.
-
- Mesaje: 33
- Membru din: Mar Feb 14, 2012 8:47 pm
Re: Sortare + copiere
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 )
Functioneaza perfect si asa dar as vrea sa trec peste o operatie ( apasarea butonului )
Re: Sortare + copiere
Foloseste codul lui IPP intrun change event in D2
Re: Sortare + copiere
Buna ziua
Testati fisierul atasat in care am folosit (care, atentie, nu este intr-un modul ci la nivel de Sheet1) codul:
IP
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
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.
-
- Mesaje: 33
- Membru din: Mar Feb 14, 2012 8:47 pm
-
- Mesaje: 33
- Membru din: Mar Feb 14, 2012 8:47 pm
Re: Sortare + copiere
Este perfect IPP ,
MUltumesc.
MUltumesc.
Re: Sortare + copiere
Eu ma gandisem la ceva de genulphanter_gl scrie: ↑Dum Oct 24, 2021 7:31 amMulțumesc pentru răspuns.
Am găsit ceva change event urmează doar să-l adaptez.
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
-
- Mesaje: 33
- Membru din: Mar Feb 14, 2012 8:47 pm
Re: Sortare + copiere
Functioneaza si aceasta solutie.
Multumesc
Multumesc