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

O

OilEconomist

Active Member
Joined
Dec 26, 2016
Messages
421
Office Version
  1. 2019
Platform
  1. Windows
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.

1649468614775.png


VBA Code: 
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
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Sort by date Sort by votes
you are make the same thing like a pivottable ?
Why don't you create such a pivottable and refresh it ?
 
Upvote 0
BSALV said:
you are make the same thing like a pivottable ?
Why don't you create such a pivottable and refresh it ?
Click to expand...
Thanks @BSALV for your response. I don’t typically like using Pivot tables because when I reference back a cell with a formula it causes issues. In this case I may have a column where I want to insert notes in between the columns so when you refresh or change it, those notes could disappear. I’ve looked for hours on the web and here are a few links to similar posts, but I could not figure out how to modify them.

This one tells you if the data exists in the original set, but I couldn’t figure out how to get the value from a corresponding column.
stackoverflow.com

What is the fastest way to pull data from one sheet to another using VBA

I have and excel file with 2 tabs, one is 166K rows and the other is 400K rows. Previously we were manually performing vlookups to pull data from the 400k row tab into the 166k row tab. I want to
stackoverflow.com stackoverflow.com

Another one
stackoverflow.com

What is the fastest way to pull data from one sheet to another using VBA

I have and excel file with 2 tabs, one is 166K rows and the other is 400K rows. Previously we were manually performing vlookups to pull data from the 400k row tab into the 166k row tab. I want to
stackoverflow.com stackoverflow.com
 
Upvote 0
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.


VBA 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
 
Upvote 0
DanteAmor said:
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.


VBA 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
Click to expand...
@DanteAmor Thank you so much as this works. I just have a few exceptions I need to work out and I will respond with them and understandably it may require a new post.
 
Upvote 0
I'm glad to help you. Thanks for the feedback.
 
Upvote 0
DanteAmor said:
I'm glad to help you. Thanks for the feedback.
Click to expand...
@DanteAmor once again thanks!

Curious to see if there are any quick modifications that can be done for
(1) if a value in the leading column the "Data" sheet does not exist, how to just leave it there as now it removes and creates a blank cell.
(2) if a value in the heading row "FRDT" within sheet "Data", does not exist in the heading row, "FRSA", of the "SA" sheet, or is blank, it gives the following error:

"Run-time error '9': Subscript out of range."

on the following line
VBA Code: 
c(i, j) = a(nRow, nCol)

Is there a way to modify the code to do nothing in that column?
 
Upvote 0
OilEconomist said:
@DanteAmor once again thanks!

Curious to see if there are any quick modifications that can be done for
(1) if a value in the leading column the "Data" sheet does not exist, how to just leave it there as now it removes and creates a blank cell.
(2) if a value in the heading row "FRDT" within sheet "Data", does not exist in the heading row, "FRSA", of the "SA" sheet, or is blank, it gives the following error:

"Run-time error '9': Subscript out of range."

on the following line
VBA Code: 
c(i, j) = a(nRow, nCol)

Is there a way to modify the code to do nothing in that column?
Click to expand...
@DanteAmor Let me rephrase

Curious to see if there are any quick modifications that can be done for
(1) if a value in the leading column the "Data" sheet does not exist, how to just leave it there as now it removes and creates a blank cell.
(2) if a value in the heading row "FRDT" within sheet "Data", is blank or does not exist in the heading row, "FRSA", of the "SA" sheet, it gives the following error:

"Run-time error '9': Subscript out of range."

on the following line

VBA Code: 
c(i, j) = a(nRow, nCol)
 
Upvote 0
OilEconomist said:
Curious to see if there are any quick modifications that can be done for
(1) if a value in the leading column the "Data" sheet does not exist, how to just leave it there as now it removes and creates a blank cell.
(2) if a value in the heading row "FRDT" within sheet "Data", is blank or does not exist in the heading row, "FRSA", of the "SA" sheet, it gives the following error:
Click to expand...
Use this:

VBA 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 = 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
 
Upvote 0
DanteAmor said:
Use this:

VBA 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 = 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
Click to expand...
@DanteAmor WOW. First check it works like you wouldn't believe!
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Excel macros extremely slow
Replies
4
Views
188
Shloime
S
F
  • Solved
Looping code sequence
Replies
5
Views
151
FrenchCelt
F
P
  • Solved
Add an IF Statement
2
Replies
10
Views
371
Joe4
Joe4
F
  • Solved
VBA set conditional formatting application-defined or object-defined error
Replies
3
Views
78
Cubist
Cubist
SanjayGMusafir
  • Solved
VBA to search Excel by Field Input Values
Replies
3
Views
286
kevin9999
K

Forum statistics

Threads
1,214,991
Messages
6,122,628
Members
449,095
Latest member
bsb1122

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top