VBA Code for Fastest Way to Pull Data from one sheet into another

[OilEconomist]

Thanks in advance for your assistance. I am attempting to write a generic VBA Code to pull data from one sheet into another based on the first column in each data set. I am currently using a Range Find Method, but that takes too long as the data set is very large and trying to make it more efficient.

The first row in each data set is the header. The pull will be based on what's in the first column and may not be pulling every column and the columns may not be in the same order. A sample data set is in the image. A sample code to start off is below and is very generic so I can use with all data sizes and sets.

Option Explicit
'***************************************************************************************************************
Sub GetData()

 '_______________________________________________________________________________________________________________
 'Turn off alerts, screen updates, and automatic calculation
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
             
             
 '_______________________________________________________________________________________________________________
 'Dimensioning
  
    'Dim longs
     Dim FRSA As Long
     Dim LRSA As Long
     Dim FCSA As Long
     Dim LCSA As Long
    
    
    'Dim strings
     Dim ShtNmSA As String
     Dim ShtNmDT As String
    

 '______________________________________________________________________________________________________________
 'Code -
    
    ShtNmSA = "SA" 'name of sheet with the source data
    ShtNmDT = "Data" 'name of the sheet which needs to pull
     
     
    With Sheets(ShtNmSA)
        FRSA = .Cells.Find(What:="*", After:=Cells(Rows.Count, Columns.Count), _
                LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, MatchCase:=False).Row
                'First row in SA which will be a header row
                
        LRSA = .Cells.Find(What:="*", After:=.Cells(1), SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row
                'Last row in SA
        
        FCSA = .Cells.Find(What:="*", After:=Cells(Rows.Count, Columns.Count), _
                LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, MatchCase:=False).Column
                'First row in SA which will be a header row
        
        LCSA = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
                'last column in SA
    End With
    
    
    With Sheets(ShtNmDT)
        FRDT = .Cells.Find(What:="*", After:=Cells(Rows.Count, Columns.Count), _
                LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, MatchCase:=False).Row
                'First row in SA which will be a header row
                
        LRDT = .Cells.Find(What:="*", After:=.Cells(1), SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row
                'Last row in SA
        
        FCDT = .Cells.Find(What:="*", After:=Cells(Rows.Count, Columns.Count), _
                LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, MatchCase:=False).Column
                'First row in SA which will be a header row
        
        LCDT = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
                'last column in SA
    End With


 '_________________________________________________________________________________________________________________
 'Code to get data
 
 
 
 '_________________________________________________________________________________________________________________
 'Turn on alerts and screen updates, and calculate
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Calculate

End Sub

 

[OilEconomist]

I guess you calculate the start row, end row, start column, and end column of each sheet, because you don't know where the data starts.
Considering that, try the following code.

Sub GetData()
  Dim FRSA As Long, LRSA As Long, FCSA As Long, LCSA As Long
  Dim FRDT As Long, LRDT As Long, FCDT As Long, LCDT As Long
  Dim shS As Worksheet, shD As Worksheet
  Dim dic1 As Object, dic2 As Object
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, nRow As Long, nCol As Long
 
  Set shS = Sheets("SA")    'name of sheet with the source data
  Set shD = Sheets("Data")  'name of the sheet which needs to pull
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
 
  dic1.CompareMode = vbTextCompare
  dic2.CompareMode = vbTextCompare
 
  'Range in SA which will be a header row
  FRSA = shS.Cells.Find("*", shS.Cells(Rows.Count, Columns.Count), xlValues, xlPart, xlByRows, xlNext).Row
  LRSA = shS.Cells.Find("*", shS.Cells(1), xlValues, xlPart, xlByRows, xlPrevious).Row
  FCSA = shS.Cells.Find("*", shS.Cells(Rows.Count, Columns.Count), xlValues, xlPart, xlColumns, xlNext).Column
  LCSA = shS.Cells.Find("*", shS.Cells(1), xlValues, xlPart, xlByColumns, xlPrevious).Column
 
  'Range in Data which will be a header row
  FRDT = shD.Cells.Find("*", shD.Cells(Rows.Count, Columns.Count), xlValues, xlPart, xlByRows, xlNext).Row
  LRDT = shD.Cells.Find("*", shD.Cells(1), xlValues, xlPart, xlByRows, xlPrevious).Row
  FCDT = shD.Cells.Find("*", shD.Cells(Rows.Count, Columns.Count), xlValues, xlPart, xlColumns, xlNext).Column
  LCDT = shD.Cells.Find("*", shD.Cells(1), xlValues, xlPart, xlByColumns, xlPrevious).Column
 
  a = shS.Range(shS.Cells(FRSA, FCSA), shS.Cells(LRSA, LCSA)).Value
  b = shD.Range(shD.Cells(FRDT, FCDT), shD.Cells(LRDT, LCDT)).Value
  ReDim c(1 To UBound(b, 1), 1 To UBound(b, 2))

  'index of rows
  For i = 1 To UBound(a, 1)
    dic1(a(i, 1)) = i
  Next
  'index of columns
  For j = 1 To UBound(a, 2)
    dic2(a(1, j)) = j
  Next
 
  For i = 1 To UBound(b, 1)
    If dic1.Exists(b(i, 1)) Then
      nRow = dic1(b(i, 1))
      For j = 1 To UBound(b, 2)
        nCol = dic2(b(1, j))
        c(i, j) = a(nRow, nCol)
      Next
    End If
  Next

  shD.Cells(FRDT, FCDT).Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub

Thanks @DanteAmor. One thing though is if a row has values or a column has values and if they don't exist in "SA", it clears the values. For now with your changes, it leaves the leading column value or heading row, but it deletes the values. How do I change it to where it leaves the values that are there.

 

[DanteAmor]

This is your initial example.

There, both the data of the rows and the headers exist in the "SA" sheet. In addition, the cells are empty.
One thing you should keep in mind when you ask a question is to present the examples as close to reality as possible, otherwise we cannot assume everything and we will not deliver a complete solution.

Try this:

Sub GetData()
  Dim FRSA As Long, LRSA As Long, FCSA As Long, LCSA As Long
  Dim FRDT As Long, LRDT As Long, FCDT As Long, LCDT As Long
  Dim shS As Worksheet, shD As Worksheet
  Dim dic1 As Object, dic2 As Object
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, nRow As Long, nCol As Long
  
  Set shS = Sheets("SA")    'name of sheet with the source data
  Set shD = Sheets("Data")  'name of the sheet which needs to pull
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  
  dic1.CompareMode = vbTextCompare
  dic2.CompareMode = vbTextCompare
  
  'Range in SA which will be a header row
  FRSA = shS.Cells.Find("*", shS.Cells(Rows.Count, Columns.Count), xlValues, xlPart, xlByRows, xlNext).Row
  LRSA = shS.Cells.Find("*", shS.Cells(1), xlValues, xlPart, xlByRows, xlPrevious).Row
  FCSA = shS.Cells.Find("*", shS.Cells(Rows.Count, Columns.Count), xlValues, xlPart, xlColumns, xlNext).Column
  LCSA = shS.Cells.Find("*", shS.Cells(1), xlValues, xlPart, xlByColumns, xlPrevious).Column
  
  'Range in Data which will be a header row
  FRDT = shD.Cells.Find("*", shD.Cells(Rows.Count, Columns.Count), xlValues, xlPart, xlByRows, xlNext).Row
  LRDT = shD.Cells.Find("*", shD.Cells(1), xlValues, xlPart, xlByRows, xlPrevious).Row
  FCDT = shD.Cells.Find("*", shD.Cells(Rows.Count, Columns.Count), xlValues, xlPart, xlColumns, xlNext).Column
  LCDT = shD.Cells.Find("*", shD.Cells(1), xlValues, xlPart, xlByColumns, xlPrevious).Column
  
  a = shS.Range(shS.Cells(FRSA, FCSA), shS.Cells(LRSA, LCSA)).Value
  b = shD.Range(shD.Cells(FRDT, FCDT), shD.Cells(LRDT, LCDT)).Value
  'ReDim c(1 To UBound(b, 1), 1 To UBound(b, 2))
  c = shD.Range(shD.Cells(FRDT + 1, FCDT + 1), shD.Cells(LRDT, LCDT)).Value
  'index of rows
  For i = 1 To UBound(a, 1)
    dic1(a(i, 1)) = i
  Next
  'index of columns
  For j = 1 To UBound(a, 2)
    dic2(a(1, j)) = j
  Next
  
  For i = 2 To UBound(b, 1)
    If dic1.Exists(b(i, 1)) Then
      nRow = dic1(b(i, 1))
      For j = 2 To UBound(b, 2)
        If dic2.Exists(b(1, j)) Then
          nCol = dic2(b(1, j))
          c(i - 1, j - 1) = a(nRow, nCol)
        End If
      Next
    End If
  Next

  shD.Cells(FRDT + 1, FCDT + 1).Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub

 

[OilEconomist]

This is your initial example.
View attachment 62281
There, both the data of the rows and the headers exist in the "SA" sheet. In addition, the cells are empty.
One thing you should keep in mind when you ask a question is to present the examples as close to reality as possible, otherwise we cannot assume everything and we will not deliver a complete solution.

Try this:

Sub GetData()
  Dim FRSA As Long, LRSA As Long, FCSA As Long, LCSA As Long
  Dim FRDT As Long, LRDT As Long, FCDT As Long, LCDT As Long
  Dim shS As Worksheet, shD As Worksheet
  Dim dic1 As Object, dic2 As Object
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, nRow As Long, nCol As Long
 
  Set shS = Sheets("SA")    'name of sheet with the source data
  Set shD = Sheets("Data")  'name of the sheet which needs to pull
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
 
  dic1.CompareMode = vbTextCompare
  dic2.CompareMode = vbTextCompare
 
  'Range in SA which will be a header row
  FRSA = shS.Cells.Find("*", shS.Cells(Rows.Count, Columns.Count), xlValues, xlPart, xlByRows, xlNext).Row
  LRSA = shS.Cells.Find("*", shS.Cells(1), xlValues, xlPart, xlByRows, xlPrevious).Row
  FCSA = shS.Cells.Find("*", shS.Cells(Rows.Count, Columns.Count), xlValues, xlPart, xlColumns, xlNext).Column
  LCSA = shS.Cells.Find("*", shS.Cells(1), xlValues, xlPart, xlByColumns, xlPrevious).Column
 
  'Range in Data which will be a header row
  FRDT = shD.Cells.Find("*", shD.Cells(Rows.Count, Columns.Count), xlValues, xlPart, xlByRows, xlNext).Row
  LRDT = shD.Cells.Find("*", shD.Cells(1), xlValues, xlPart, xlByRows, xlPrevious).Row
  FCDT = shD.Cells.Find("*", shD.Cells(Rows.Count, Columns.Count), xlValues, xlPart, xlColumns, xlNext).Column
  LCDT = shD.Cells.Find("*", shD.Cells(1), xlValues, xlPart, xlByColumns, xlPrevious).Column
 
  a = shS.Range(shS.Cells(FRSA, FCSA), shS.Cells(LRSA, LCSA)).Value
  b = shD.Range(shD.Cells(FRDT, FCDT), shD.Cells(LRDT, LCDT)).Value
  'ReDim c(1 To UBound(b, 1), 1 To UBound(b, 2))
  c = shD.Range(shD.Cells(FRDT + 1, FCDT + 1), shD.Cells(LRDT, LCDT)).Value
  'index of rows
  For i = 1 To UBound(a, 1)
    dic1(a(i, 1)) = i
  Next
  'index of columns
  For j = 1 To UBound(a, 2)
    dic2(a(1, j)) = j
  Next
 
  For i = 2 To UBound(b, 1)
    If dic1.Exists(b(i, 1)) Then
      nRow = dic1(b(i, 1))
      For j = 2 To UBound(b, 2)
        If dic2.Exists(b(1, j)) Then
          nCol = dic2(b(1, j))
          c(i - 1, j - 1) = a(nRow, nCol)
        End If
      Next
    End If
  Next

  shD.Cells(FRDT + 1, FCDT + 1).Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub

Thanks @DanteAmor that works and I will mark as the solution. Apologies about not being clear. I posted the example as I could not post the original data as it is confidential. I did not think about blank spaces or columns as the codes that I used in the past worked on those, but those codes were too slow. I will try to be more mindful in the future.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[OilEconomist]

@DanteAmor, I am trying to understand your code mainly because it was so fast and you did a great job. I want to learn how to use scripting dictionaries. Also, in the case I want to use the methodology and or have to make a modification in the future. But I understand if you do not have time to explain so no worries. But does this sound correct?

This stores all of the values from ShS including the leading column and heading.

a = shS.Range(shS.Cells(FRSA, FCSA), shS.Cells(LRSA, LCSA)).Value

This stores all the values from ShD including the leading column and heading.

b = shD.Range(shD.Cells(FRDT, FCDT), shD.Cells(LRDT, LCDT)).Value

This stores all the values in ShS except the leading column and the heading row.

c = shD.Range(shD.Cells(FRDT + 1, FCDT + 1), shD.Cells(LRDT, LCDT)).Value

This stores the values in the leading column of ShS.

'index of rows
  For i = 1 To UBound(a, 1)
    dic1(a(i, 1)) = i
  Next

The stores the heading of ShS.

  'index of columns
  For j = 1 To UBound(a, 2)
    dic2(a(1, j)) = j
  Next

This is the loop which performs the actual data extraction? Say I wanted to only get data in the 20th row and heading row might be row 8, and or I want to get data in the 10th column where the leading column is column 2, is this the code that I would change? It looks like the way you have it set up, it assumes continuous rows and columns will be extracted. I'm not asking you to make any more changes, just trying to understand it.

For i = 2 To UBound(b, 1)
    If dic1.Exists(b(i, 1)) Then
      nRow = dic1(b(i, 1))
      For j = 2 To UBound(b, 2)
        If dic2.Exists(b(1, j)) Then
          nCol = dic2(b(1, j))
          c(i - 1, j - 1) = a(nRow, nCol)
        End If
      Next
    End If
  Next

What does this line of code actually do?

shD.Cells(FRDT + 1, FCDT + 1).Resize(UBound(c, 1), UBound(c, 2)).Value = c

 

[DanteAmor]

This stores all of the values from ShS including the leading column and heading.

a = shS.Range(shS.Cells(FRSA, FCSA), shS.Cells(LRSA, LCSA)).Value

Yes.

This stores all the values from ShD including the leading column and heading.

b = shD.Range(shD.Cells(FRDT, FCDT), shD.Cells(LRDT, LCDT)).Value

Yes.

This stores all the values in ShS except the leading column and the heading row.

c = shD.Range(shD.Cells(FRDT + 1, FCDT + 1), shD.Cells(LRDT, LCDT)).Value

That's right, it's the green area:

This stores the values in the leading column of ShS.

  For i = 1 To UBound(a, 1)
    'It stores in the index the data 'a(i, 1)' of the main column (the "source")
                    'and for each index stores the row number 'i'
    dic1(a(i, 1)) = i
  Next

The stores the heading of ShS.

  For j = 1 To UBound(a, 2)
    'It stores in the index the data 'a(1, j)' of the Headers
                    'and for each index stores the COLUMN number 'j'
    dic2(a(1, j)) = j
  Next

This is the loop which performs the actual data extraction?

  'How the loop works, in fact there are 2 loops, one for the rows and one for the columns.
  'Read the rows on the Data sheet
  For i = 2 To UBound(b, 1)
    'In the example take the data "Source1" yellow cell.
    If dic1.Exists(b(i, 1)) Then
      'If it exists, then it takes the row number stored in that index.
      nRow = dic1(b(i, 1))
      For j = 2 To UBound(b, 2)
        'Read the columns on the Data sheet, for row 'i'
         'In the example take the data "COUNTRY" blue cell.
        If dic2.Exists(b(1, j)) Then
          'If it exists, but in dic2, then it takes the column number stored in that index.
          nCol = dic2(b(1, j))
          'Then extracts the data (row, column) from the SHS sheet and puts it in the matrix c.
          'It is stored in the matrix 'c' in the row according to the counter,
          'as it started in 2, we need to save in 1, that's why it is i - 1
          c(i - 1, j - 1) = a(nRow, nCol)
        End If
      Next
    End If
  Next

What does this line of code actually do?

shD.Cells(FRDT + 1, FCDT + 1).Resize(UBound(c, 1), UBound(c, 2)).Value = c

That, technically passes the data from the matrix 'c' to the sheet.
The advantage of doing everything in matrices is that the processes are done in memory, it does not work with the cells and that is why the processes are faster. Then the data is stored in an 'c' array in memory. In the end we must pass the data from the matrix to the cells, but this is done in a single step, so the process is faster.
Explanation of that line:
FRDT contains the header row, but 1 is added to start in the green area (remember?), same with FCDT. Sizes the area that will receive the data, number of rows contained in the array 'c' (ubound(c,1)), number of columns contained in the array 'c' (ubound(c,2)).

I hope the explanation is helpful.

 

[OilEconomist]

Yes.


Yes.



That's right, it's the green area:
View attachment 62435

  For i = 1 To UBound(a, 1)
    'It stores in the index the data 'a(i, 1)' of the main column (the "source")
                    'and for each index stores the row number 'i'
    dic1(a(i, 1)) = i
  Next

  For j = 1 To UBound(a, 2)
    'It stores in the index the data 'a(1, j)' of the Headers
                    'and for each index stores the COLUMN number 'j'
    dic2(a(1, j)) = j
  Next

  'How the loop works, in fact there are 2 loops, one for the rows and one for the columns.
  'Read the rows on the Data sheet
  For i = 2 To UBound(b, 1)
    'In the example take the data "Source1" yellow cell.
    If dic1.Exists(b(i, 1)) Then
      'If it exists, then it takes the row number stored in that index.
      nRow = dic1(b(i, 1))
      For j = 2 To UBound(b, 2)
        'Read the columns on the Data sheet, for row 'i'
         'In the example take the data "COUNTRY" blue cell.
        If dic2.Exists(b(1, j)) Then
          'If it exists, but in dic2, then it takes the column number stored in that index.
          nCol = dic2(b(1, j))
          'Then extracts the data (row, column) from the SHS sheet and puts it in the matrix c.
          'It is stored in the matrix 'c' in the row according to the counter,
          'as it started in 2, we need to save in 1, that's why it is i - 1
          c(i - 1, j - 1) = a(nRow, nCol)
        End If
      Next
    End If
  Next

View attachment 62436



That, technically passes the data from the matrix 'c' to the sheet.
The advantage of doing everything in matrices is that the processes are done in memory, it does not work with the cells and that is why the processes are faster. Then the data is stored in an 'c' array in memory. In the end we must pass the data from the matrix to the cells, but this is done in a single step, so the process is faster.
Explanation of that line:
FRDT contains the header row, but 1 is added to start in the green area (remember?), same with FCDT. Sizes the area that will receive the data, number of rows contained in the array 'c' (ubound(c,1)), number of columns contained in the array 'c' (ubound(c,2)).

I hope the explanation is helpful.

@DanteAmor Thanks so much for this solution as it has saved me so much time and helped me immensely. It was really slick and simple (short).

So understandably I may need to start a new thread, but I would like to go ahead and ask if there is a toggle to do the following. As I get my assignments, things change so that's why I never included it initially.

Is there a way to place a toggle to where if the cell being updated is left alone if the cell

ShS = Sheets("SA")

is blank? I would like the option to be able to overwrite the data with the blank cell or not.

My idea of the toggle, would be just like a "Yes" or "No"

Dim Replace_with_Blanks 'either "Yes" replace blanks or "No", do not replace with blanks. Basically if cells from the source data are blank, do not overwrite the data for _
respective cell in shD.

If Replace_with_Blanks = "Yes" Then

ElseIf Replace_with_Blanks = "No" Then

EndIf

Here's an example of ShS ("SA") and then shD ("Data") before the update and after

shS

Book2
	A	B	C	D
1	Region	Color	Space	Zone
2	Region 1			2
3	Region 2	Blue	10	3
4	Region 3	Green	22	4
5	Region 4	Yellow		4
6	Region 5	Purple	33	2
7	Region 6	Green		2
8	Region 7	Brown	22	3
SA

shD (before)

Book2
	A	B	C
1	Region	Space	Color
2	Region 1	10	Red
3	Region 2	20
4	Region 4		Green
5	Region 6	30	Blue
Data

shD (after) (cells in yellow didn't change, i.e. did not get overwritten with blanks)

Book2
	A	B	C
1	Region	Space	Color
2	Region 1	10	Red
3	Region 2	10	Blue
4	Region 4		Yellow
5	Region 6	30	Green
Data