Copy sht1 to sht2 based criteria (Script.Dictionary)

marreco

Well-known Member
Joined
Jan 1, 2011
Messages
607
I need copy data to another sheet
My tab("Relatorio") hava CFOP in column M, if find any value start 1 or 2 like this(
1253/AA1949/ZZ2102/AA2353/AA2920/AA)

<tbody>
</tbody>
Copy to tab("Saida") case start like this(
5921/AA6152/AA6202/AA

<colgroup><col width="64" span="3"></colgroup><tbody>
</tbody>
)

Copy to tab("Entrada")


CFOPGo to tab
1253/AAEntrada
1949/ZZEntrada
2102/AAEntrada
2353/AAEntrada
2920/AAEntrada
5921/AASaida
6152/AASaida
6202/AASaida

<colgroup><col style="width:48pt" width="64" span="2"> </colgroup><tbody>
</tbody>
This is the code:
Code:
Sub Copy_sht1_To_sht2()
'This code made by  Fluff, I try adapt
    Dim ws As Worksheet
    Dim UsdRws As Long
    Dim Fltr As Variant
    Dim Val As Variant
    Dim Cl As Range
    Dim Dict As Object
    
    Set ws = Sheets("Relatorio")
    UsdRws = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Set Dict = CreateObject("scripting.dictionary")
    Fltr = Array("5*", "6*") 'Array("5921/AA", "6152/AA", "6202/AA")
    
    With ws
        For Each Val In Fltr
            For Each Cl In .Range("M2:M" & UsdRws)
                If Cl.Value Like Val Then Dict(Cl.Value) = vbNullString
            Next Cl
        Next Val
        .Range("A1:AS" & UsdRws).AutoFilter Field:=13, Criteria1:=Dict.Keys, Operator:=xlFilterValues
        .AutoFilter.Range.Offset(1).Copy Sheets("Saida").Range("A" & Rows.Count).End(xlUp).Offset(1)
        'If Cl.Value = Fltr Then
        '    .Range("A1:AS" & UsdRws).AutoFilter Field:=13, Criteria1:=Dict.Keys, Operator:=xlFilterValues
        '    .AutoFilter.Range.Offset(1).Copy Sheets("Saida").Range("A" & Rows.Count).End(xlUp).Offset(1)
        'Else
        '    .Range("A1:AS" & UsdRws).AutoFilter Field:=13, Criteria1:=Dict.Keys, Operator:=xlFilterValues
        '    .AutoFilter.Range.Offset(1).Copy Sheets("Entrada").Range("A" & Rows.Count).End(xlUp).Offset(1)
        'End If
    End With
    ws.AutoFilterMode = False
    Set ws = Nothing
    Set Dict = Nothing
End Sub
 

Some videos you may like

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
46,113
Office Version
  1. 365
Platform
  1. Windows
Try
Code:
Sub marreco()
   Dim UsdRws As Long
   
   With Sheets("Relatorio")
      If .AutoFilterMode Then .AutoFilterMode = False
      UsdRws = .Range("M" & Rows.Count).End(xlUp).Row
      .Range("A1:AS" & UsdRws).AutoFilter 13, "5*", xlOr, "6*"
      .AutoFilter.Range.Offset(1).Copy Sheets("Entrada").Range("A" & Rows.Count).End(xlUp).Offset(1)
      .Range("A1:AS" & UsdRws).AutoFilter 13, "1*", xlOr, "2*"
      .AutoFilter.Range.Offset(1).Copy Sheets("Saida").Range("A" & Rows.Count).End(xlUp).Offset(1)
      .AutoFilterMode = False
   End With
End Sub
 

marreco

Well-known Member
Joined
Jan 1, 2011
Messages
607
Yeah, this work!

But I try learn about script.Dictinary. Can you provide a example using dictionary?

Thank you!!
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
46,113
Office Version
  1. 365
Platform
  1. Windows
There's no need to use a Dictionary for that.
If you want examples of Dictionaries, just do an advance search and it will pull up loads of threads.
 

Watch MrExcel Video

Forum statistics

Threads
1,108,678
Messages
5,524,241
Members
409,566
Latest member
MickB

This Week's Hot Topics

Top