Extract data using Scripting Dictionary

[abc_xyz]

I am trying to extract data from Source file and paste it into their respective template file.

Column E	Column F
Country	File path
Brazil	C:\Users\ABC123\Desktop\Brazil.xlsx
USA	C:\Users\ABC123\Desktop\USA.xlsx

Requirement: Copy rows from the source file which has the same country from Column E and paste the entire row in the file path provided in the next cell.

The code seems to paste entire data set for the listed countries. It should paste Brazil's data into brazils file and so on. Can someone please help?

Also asked here Copy data from Master File and Paste to their Respective file

Sub test1()


Dim SourceFilePath, SourceSheet, CountryName, DestinationFilePath, NewSheetName, File_Name As String
Dim OpenSource, OpenDestination As Workbook
Dim cl As Range, Rng As Range
Dim Dic As Object
Dim StartTime As Double
Dim MinutesElapsed As String
Dim i, lastrow As Long




With Application
   .ScreenUpdating = True
   .DisplayAlerts = False
   .EnableEvents = False
End With



lastrow = ThisWorkbook.Sheets("Dashboard").Range("E" & Rows.Count).End(xlUp).Row
SourceFilePath = ThisWorkbook.Sheets("Dashboard").Range("F3")
SourceSheet = ThisWorkbook.Sheets("Dashboard").Range("G3")


Set Dic = CreateObject("scripting.dictionary")
   
'Add Key words to dictionary
    With ThisWorkbook.Sheets("Dashboard")
  
        For Each cl In .Range("E12", .Range("E" & Rows.Count).End(xlUp))
           
            Dic(cl.Value) = cl.Value
       
        Next cl
       
    End With




Set OpenSource = Workbooks.Open(SourceFilePath)




'Loop through each Key in the Dictionary
For Each Key In Dic.keys

    For i = 12 To lastrow


DestinationFilePath = ThisWorkbook.Sheets("Dashboard").Cells(i, 6)
NewSheetName = ThisWorkbook.Sheets("Dashboard").Cells(i, 7)
File_Name = ThisWorkbook.Sheets("Dashboard").Cells(i, 8)

Set OpenDestination = Workbooks.Open(DestinationFilePath)

        With OpenSource.Sheets(SourceSheet)

                For Each cl In .Range("V2", .Range("V" & Rows.Count).End(xlUp))
           
                    If Dic.Exists(cl.Value) Then
                        If Rng Is Nothing Then Set Rng = cl Else Set Rng = Union(Rng, cl)
                    End If
       
                Next cl
           
                    If Not Rng Is Nothing Then Rng.EntireRow.Copy

        End With


        With OpenDestination.Sheets(SourceSheet)
            .Range("A2").PasteSpecial Paste:=xlPasteValues
        End With


    Next i

Next Key





With Application
   .ScreenUpdating = True
   .DisplayAlerts = True
   .EnableEvents = True
End With




End Sub

 

[abc_xyz]

Can anyone please help?

 

[Dan_W]

Hi. I don't know if I'll be much help, but I can try. Is there any reason in particular it needs to be a dictionary?

 

[abc_xyz]

Hi. I don't know if I'll be much help, but I can try. Is there any reason in particular it needs to be a dictionary?

Data size is massive. Hence, I believe dictionary method would one of the best way to get the work done. Happy to hear if you thing otherwise.

 

[Dan_W]

How big is 'massive'?

 

[abc_xyz]

How big is 'massive'?

3 letter Columns and Around a million rows

 

[Dan_W]

Pfft... is that all?

(No, fair play, that's pretty darn big)

I gather that with this line:

If Not Rng Is Nothing Then Rng.EntireRow.Copy

You're intending to copy all of the relevant rows (and only the relevant rows) at once?

 

[abc_xyz]

Pfft... is that all?

(No, fair play, that's pretty darn big)

I gather that with this line:

If Not Rng Is Nothing Then Rng.EntireRow.Copy

You're intending to copy all of the relevant rows (and only the relevant rows) at once?

Yes, it keeps the row's address in memory where it has found the dictionary value and copies all the relevant rows at once

 

[Dan_W]

Ok. So I've just finished going through the code. It's a bit tricky without anything in front of me to work with - is it possible to pull together some mock data? There is an add-in on this site called XL2BB that can copy data from an excel spreadsheet and format it into a very manageable data set for posting here on the forum.
Other than that, a couple of things:
(1) I would suggest stepping through the code and seeing where things go wrong - have done that before?
(2) You need to stipulate the the data type for each variable when you declare it - you can't put "As String" as the end of the line and expect that it will declare everything before it as a string. It won't It will, by default, make those variables all Implicit Variants. This can cause problems. So:

Dim SourceFilePath As String, SourceSheet As String, CountryName As String, DestinationFilePath As String, NewSheetName As String, File_Name As String
Dim OpenSource As Workbook, OpenDestination As Workbook
Dim cl As Range, celz As Range, Rng As Range
Dim Dict As Object
Dim StartTime As Double
Dim MinutesElapsed As String
Dim i As Long, lastrow As Long

It may not solve your current issues, but it's best to make sure you know what data type you're actually dealing with.

(3) Without any data, it's hard to say, but I suspect the bug may be somewhere in these two lines..

For Each celz In .Range("V2", .Range("V" & Rows.Count).End(xlUp))
            If Dict.Exists(celz.value) Then

Let me know your thoughts on the above.

 

[abc_xyz]

Well, I had tried a different approach as well. Would appreciate if you could take a look at the code and share your thoughts.

Sub dict_test()

Dim SourceFilePath, SourceSheet, CountryName, DestinationFilePath, NewSheetName, File_Name As String
Dim OpenSource, OpenDestination As Workbook
Dim cl, celz, Rng As Range
Dim Dict As Object
Dim StartTime As Double
Dim MinutesElapsed As String
Dim i, lastrow As Long

Set Dict = CreateObject("scripting.dictionary")
MyRng = ThisWorkbook.Sheets("Dashboard").Range("E12:E" & Cells(Rows.Count, "E").End(xlUp).Row).Value



SourceFilePath = ThisWorkbook.Sheets("Dashboard").Range("F3")
SourceSheet = ThisWorkbook.Sheets("Dashboard").Range("G3")


Set OpenSource = Workbooks.Open(SourceFilePath)



With ThisWorkbook.Sheets("Dashboard")
  
        For Each cl In .Range("E12", .Range("E" & Rows.Count).End(xlUp))
            
            Dict(cl.Value) = cl.Offset(, 1).Value
              
        Next cl
        
End With


For Each ikey In Dict.keys
    
    CountryName = ikey
    DestinationFilePath = Dict(ikey)
    
    
    Set OpenDestination = Workbooks.Open(DestinationFilePath)
    
    
    With OpenSource.Sheets(SourceSheet)

        For Each celz In .Range("V2", .Range("V" & Rows.Count).End(xlUp))
            
            If Dict.Exists(celz.Value) Then
                If Rng Is Nothing Then Set Rng = celz Else Set Rng = Union(Rng, celz)
            End If
        
        Next celz
            
                If Not Rng Is Nothing Then Rng.EntireRow.Copy

    End With
    
    
    With OpenDestination.Sheets(SourceSheet)
        .Range("A2").PasteSpecial
    End With
    


    Set OpenDestination = Nothing


Next




End Sub