I was hoping to be able to have a macro that would be able to extract the ID from each of our orders and put them into table 3.
Lookup Data (Excel Tables)
Option Explicit
Sub LookupData()
Const lName As String = "Sheet1"
Const ltName As String = "Table1"
Const lcName As String = "Table 1"
Const sName As String = "Sheet1"
Const stName As String = "Table2"
Const sclName As String = "Table 2"
Const scvName As String = "ID"
Const dName As String = "Sheet2"
Const dtName As String = "Table3"
Const dclName As String = "Table 3 (RESULTS)"
Const dcvName As String = "ID"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Lookup
Dim lws As Worksheet: Set lws = wb.Worksheets(lName)
Dim ltbl As ListObject: Set ltbl = lws.ListObjects(ltName)
Dim lrCount As Long: lrCount = ltbl.Range.Rows.Count
Dim lcl As ListColumn: Set lcl = ltbl.ListColumns(lcName) ' Lookup Column
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim stbl As ListObject: Set stbl = sws.ListObjects(stName)
Dim scl As ListColumn: Set scl = stbl.ListColumns(sclName)
Dim slrg As Range: Set slrg = scl.DataBodyRange ' Lookup Column
Dim scv As ListColumn: Set scv = stbl.ListColumns(scvName)
Dim svrg As Range: Set svrg = scv.DataBodyRange
Dim svData As Variant: svData = svrg.Value ' Value Array
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dtbl As ListObject: Set dtbl = dws.ListObjects(dtName)
Dim drCount As Long: drCount = dtbl.Range.Rows.Count
Dim dcl As ListColumn: Set dcl = dtbl.ListColumns(dclName) ' written to
Dim dcv As ListColumn: Set dcv = dtbl.ListColumns(dcvName) ' written to
' Copy lookup column.
dcl.DataBodyRange.Resize(lrCount - 1).Value = lcl.DataBodyRange.Value
Dim lData As Variant: lData = lcl.DataBodyRange.Value ' Lookup Array
Dim dvData As Variant: ReDim dvData(1 To lrCount - 1, 1 To 1) ' Value Array
Dim sIndex As Variant
Dim r As Long
' Match value data.
For r = 1 To lrCount - 1
sIndex = Application.Match(lData(r, 1), slrg, 0)
If IsNumeric(sIndex) Then
dvData(r, 1) = svData(sIndex, 1)
End If
Next r
' Copy value array to value range.
dcv.DataBodyRange.Value = dvData
If lrCount < drCount Then
' Resize and clear.
dtbl.Resize dtbl.Range.Resize(lrCount)
dtbl.DataBodyRange.Resize(drCount - lrCount).Offset(lrCount - 1).Clear
End If
End Sub
Related
The cells contain different lengths of data. I tried text to column. It does not work because of the number of dots.
How can I populate each text or number in separate cells by ignoring the number of dots than delete the line anywhere there is an empty cell in column A and B?
Data exemple:
Split Data
Associated
Sub SplitAssociated()
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "A1"
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "B1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim srg As Range
Dim rCount As Long
With sfCell.Resize(sws.Rows.Count - sfCell.Row + 1)
Dim slCell As Range
Set slCell = .Find("*", , xlFormulas, , , xlPrevious)
rCount = slCell.Row - .Row + 1
Set srg = .Resize(rCount)
End With
Dim Data As Variant
Data = sws.Evaluate("TRIM(SUBSTITUTE(" & srg.Address & ",""."","" ""))")
Dim SubStrings() As Variant: ReDim SubStrings(1 To rCount)
Dim Lens() As Long: ReDim Lens(1 To rCount)
Dim r As Long
Dim cCount As Long
Dim cString As String
For r = 1 To rCount
cString = Data(r, 1)
If Len(cString) > 0 Then
SubStrings(r) = Split(cString)
Lens(r) = UBound(SubStrings(r)) + 1
If Lens(r) > cCount Then cCount = Lens(r)
End If
Next r
ReDim Data(1 To rCount, 1 To cCount)
Dim c As Long
For r = 1 To rCount
For c = 1 To Lens(r)
Data(r, c) = SubStrings(r)(c - 1)
Next c
Next r
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim drg As Range: Set drg = dfCell.Resize(rCount, cCount)
drg.Value = Data
drg.Resize(dws.Rows.Count - drg.Row - rCount + 1).Offset(rCount).Clear
End Sub
Remove Blanks
Sub SplitRemoveBlanks()
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "A1"
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "C1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim srg As Range
Dim srCount As Long
With sfCell.Resize(sws.Rows.Count - sfCell.Row + 1)
Dim slCell As Range
Set slCell = .Find("*", , xlFormulas, , , xlPrevious)
srCount = slCell.Row - .Row + 1
Set srg = .Resize(srCount)
End With
Dim Data As Variant
Data = sws.Evaluate("TRIM(SUBSTITUTE(" & srg.Address & ",""."","" ""))")
Dim SubStrings() As Variant: ReDim SubStrings(1 To srCount)
Dim Lens() As Long: ReDim Lens(1 To srCount)
Dim sr As Long
Dim drCount As Long
Dim dcCount As Long
Dim cString As String
For sr = 1 To srCount
cString = Data(sr, 1)
If Len(cString) > 0 Then
drCount = drCount + 1
SubStrings(sr) = Split(cString)
Lens(sr) = UBound(SubStrings(sr)) + 1
If Lens(sr) > dcCount Then dcCount = Lens(sr)
End If
Next sr
ReDim Data(1 To drCount, 1 To dcCount)
Dim dr As Long
Dim dc As Long
For sr = 1 To srCount
If Lens(sr) > 0 Then
dr = dr + 1
For dc = 1 To Lens(sr)
Data(dr, dc) = SubStrings(sr)(dc - 1)
Next dc
End If
Next sr
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
drg.Value = Data
drg.Resize(dws.Rows.Count - drg.Row - drCount + 1).Offset(drCount).Clear
End Sub
If the "." (dot) is the element to be stripped from strings in cells (eg no floating point numbers, nor "." is an important mark), you can use this code including deleting entire lines.
The code loops through the specified range (oRng) and when it finds ".." it will replace it with ".". Then, when no more ".." is found, indicating that the replacement job has completed, generating an error (caught), it proceeds to delete the blank rows from the blank cells in column "A".
Option Explicit
Sub fnCleanAndSplit()
Dim oRng As Excel.Range
Dim oCell As Excel.Range
Dim fDone As Boolean
Set oRng = ThisWorkbook.Sheets(1).Range("A1:A7")
Do
For Each oCell In oRng.Cells
oCell.Value = VBA.Replace(oCell.Value, "..", ".")
Next
On Error GoTo lblDone
fDone = oRng.Find("..") = ""
On Error GoTo 0
Loop Until fDone
lblDone:
oRng.TextToColumns Destination:=oRng.Cells(1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Other:=True, OtherChar _
:=".", TrailingMinusNumbers:=True
oRng.SpecialCells(xlCellTypeBlanks).Select
oRng.Parent.Activate 'just in case it is not activated
Selection.EntireRow.Delete
End Sub
I want to take the active cell in the For Each, "vlookup" it in another sheet, and bring back the value from the cell to the right of it.
The problem is in .find(cell.value).
Option Explicit
Sub EmailRep()
Dim range1, range2, cell As Range
Dim ult_email As String
Dim ult_linha As Integer
Dim linha_atual As Integer
Dim Email_atual As String
Set range2 = Sheets("Planilha1").Range("B2:B21")
Set range1 = Range("D4:D19")
linha_atual = range1.Cells(1, 1).Row
ult_linha = 19
ult_email = Email_atual
Email_atual = ult_email
For Each cell In range1
If cell.Value <> ult_email Then
Email_atual = cell.Value
ult_email = cell.Value
Else
cell.Value = range2.Find(cell.Value).Offset(1, 1)
MsgBox (cell)
End If
linha_atual = linha_atual + 1
Next
End Sub
A VBA Lookup (Loop, Dictionary)
This may not be what you need but check it out. It will return the unique column pairs of one two-column range in another worksheet's two-column range.
Adjust (play with) the values in the constants section (a second worksheet name was never mentioned).
Option Explicit
Sub EmailRep()
' Source (Read)
Const sName As String = "Planilha1"
Const sfCol As String = "A"
Const sfRow As Long = 2
' Destination (Write)
Const dName As String = "Planilha2"
Const dfCol As String = "D"
Const dfRow As Long = 4
Const DoClearBelow As Boolean = True
Const DoSort As Boolean = True
' Both
Const Delimiter As String = "|" ' something that doesn't appear in the data
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sfCol).End(xlUp).Row
Dim srg As Range: Set srg = sws.Range( _
sws.Cells(sfRow, sfCol), sws.Cells(slRow, sfCol)).Resize(, 2)
' Write from the source range to the dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim srrg As Range
Dim sString As String
For Each srrg In srg.Rows ' loop through rows
sString = srrg.Cells(1) & Delimiter & srrg.Cells(2)
dict(sString) = Empty
Next srrg
Dim rCount As Long: rCount = dict.Count
Application.ScreenUpdating = False
' Write from the dictionary to the destination range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim drg As Range: Set drg = dws.Cells(dfRow, dfCol).Resize(rCount, 2)
Dim Key As Variant
Dim r As Long
For Each Key In dict.Keys
r = r + 1
drg.Rows(r).Value = Split(Key, Delimiter)
Next Key
' Clear below.
If DoClearBelow Then
drg.Resize(dws.Rows.Count - drg.Row - rCount + 1).Offset(rCount).Clear
End If
' Sort.
If DoSort Then drg.Sort drg.Columns(1), xlAscending
Application.ScreenUpdating = True
MsgBox "Data created.", vbInformation
End Sub
My idea is to get the data that I have on "A4" ("Data" worksheet) and paste it 4 times on "B4" ("Forecast" worksheet). After that, take the data from "A5" and do the same (starting from the first blank cell) until there is no more data on the "A" column. After there is no more data, the process should stop.
How do I tell excel to paste the value in the first blank cell in column B ("Forecast" worksheet)?
Sub Test()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim i As Integer, k As Integer
Set wsSource = ThisWorkbook.Worksheets("Data")
Set wsTarget = ThisWorkbook.Worksheets("Forecast")
k = wsSource.Range("A4", wsSource.Range("A4").End(xlDown)).Rows.Count
For i = 1 To k
wsTarget.Range("B4", "B7").Value = wsSource.Range("A" & 3 + i).Value
Next
End Sub
Copy Repetitions
A Quick Fix
Sub Test()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim sCell As Range, tCell As Range
Dim i As Long, j As Long, k As Long
Set wsSource = ThisWorkbook.Worksheets("Data")
Set wsTarget = ThisWorkbook.Worksheets("Forecast")
k = wsSource.Range("A4", wsSource.Range("A4").End(xlDown)).Rows.Count
Set sCell = wsSource.Range("A4")
Set tCell = wsTarget.Range("B4")
For i = 1 To k
For j = 1 To 4
tCell.Value = sCell.Value
Set tCell = tCell.Offset(1)
Next j
Set sCell = sCell.Offset(1)
Next i
End Sub
My Choice
Sub CopyRepetitions()
' Source
Const sName As String = "Data"
Const sfCellAddress As String = "A4"
' Destination
Const dName As String = "Forecast"
Const dfCellAddress As String = "B4"
Const Repetitions As Long = 4
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source (one-column) range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range
Dim srCount As Long
With sws.Range(sfCellAddress)
Dim lCell As Range: Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub ' no data
srCount = lCell.Row - .Row + 1
Set srg = .Resize(srCount)
End With
' Write values from the source range the source array ('sData')
Dim sData As Variant
If srCount = 1 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else
sData = srg.Value
End If
' Define the destination array ('dData').
Dim drCount As Long: drCount = srCount * Repetitions
Dim dData As Variant: ReDim dData(1 To drCount, 1 To 1)
' Write the repeating values from the source- to the destination array.
Dim sr As Long
Dim rep As Long
Dim dr As Long
For sr = 1 To srCount
For rep = 1 To Repetitions
dr = dr + 1
dData(dr, 1) = sData(sr, 1)
Next rep
Next sr
' Write the values from the destination array to the destination
' one-column range and clear the data below.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dfCellAddress)
.Resize(drCount).Value = dData
.Resize(dws.Rows.Count - .Row - drCount + 1).Offset(drCount).Clear
End With
' Inform.
MsgBox "Repetitions copied.", vbInformation
End Sub
I have two sheets and I need to get names of fields for each person. For that I need to take a person of a row in sheet2 then i have to get the fields which this person is assigned in the sheet1 on the right table (for every rows). For this part I found and modified this VBA code, but it doesn't do what I need ... :
Dim rgFound As Range
Dim defVal As Range
Dim currParam As Range
Dim currParamDict As Range
With Worksheets("Sheet2")
For Each defVal In .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Offset(, 1)
Set currParam = defVal.Offset(, -1)
If Len(currParam.Value) > 0 Then
Set rgFound = Worksheets("Sheet1").Range("F9:I12").Find(currParam.Value)
If rgFound Is Nothing Then
Debug.Print "Name was not found."
Else
Set currParamDict = rgFound.Offset(, 0)
defVal.Value = currParamDict.Value
End If
End If
Next defVal
End With
I dont know for the range in : Set rgFound = Worksheets("Sheet1").Range("F9:I12").Find(currParam.Value)
I put some example pictures so you can see what it is about.
Sheet1 :
Sheet2 :
After this step, I have to fill the dates corresponding to fields using the left table of the Sheet1...
Fill a Table
Off Track
Ignore possible old data in Sheet2 and write the complete table.
Option Explicit
Sub FillTable()
' Source Dates
Const sdName As String = "Sheet1"
Const sdFirst As String = "B2"
' Source Cities
Const scName As String = "Sheet1"
Const scFirst As String = "F9"
' Destination
Const dName As String = "Sheet2"
Const dFirst As String = "B2"
Const dHeader As String = "Name"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source Dates
Dim sdws As Worksheet: Set sdws = wb.Worksheets(sdName)
Dim sdrg As Range: Set sdrg = sdws.Range(sdFirst).CurrentRegion
Dim sdData As Variant: sdData = sdrg.Value
Dim sdrCount As Long: sdrCount = sdrg.Rows.Count
Dim sdcCount As Long: sdcCount = sdrg.Columns.Count
' Source Cities
Dim scws As Worksheet: Set scws = wb.Worksheets(scName)
Dim scrg As Range: Set scrg = scws.Range(scFirst).CurrentRegion
Dim scData As Variant: scData = scrg.Value
Dim schrg As Range: Set schrg = scrg.Rows(1)
Dim scrCount As Long: scrCount = scrg.Rows.Count
Dim sctCount As Long: sctCount = Application.CountA(scrg)
' Destination Array
Dim drCount As Long: drCount = sctCount + 1 ' '+ 1' for headers
Dim dcCount As Long: dcCount = 1 + sdcCount ' 1 for 'Name'
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' Write headers to Destination Array.
Dim sdc As Long
dData(1, 1) = dHeader
For sdc = 1 To sdcCount
dData(1, sdc + 1) = sdData(1, sdc)
Next sdc
' Write 'body' to Destination Array.
Dim dr As Long: dr = 1 ' 1 for headers
Dim sccIndex As Variant
Dim scValue As Variant
Dim sdr As Long
Dim scr As Long
For sdr = 2 To sdrCount
sccIndex = Application.Match(sdData(sdr, 1), schrg, 0)
For scr = 2 To scrCount
scValue = scData(scr, sccIndex)
If Not IsError(scValue) Then
If Len(scValue) > 0 Then
dr = dr + 1
dData(dr, 1) = scValue
For sdc = 1 To sdcCount
dData(dr, sdc + 1) = sdData(sdr, sdc)
Next sdc
End If
End If
Next scr
Next sdr
' Write Destination Array to Destination Range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfcell As Range: Set dfcell = dws.Range(dFirst)
Dim drg As Range: Set drg = dfcell.Resize(drCount, dcCount)
drg.Value = dData
' Clear Destination Clear Range, the range below Destination Range.
Dim dcrg As Range
Set dcrg = drg.Resize(drg.Worksheet.Rows.Count - drg.Row - drCount + 1) _
.Offset(drCount)
dcrg.Clear ' or 'dcrg.ClearContents'
' Format e.g.:
drg.Rows(1).Font.Bold = True
dws.Range(drg.Columns(3), drg.Columns(dcCount)).Resize(drCount - 1) _
.Offset(1).NumberFormat = "dd/mm/yyyy" ' possibly "dd\/mm\/yyyy"
drg.EntireColumn.AutoFit
'wb.Save
End Sub
Meeting the Requirement
There are the names in Sheet2, so fill the other columns.
Sub FillTable2()
' Source Dates
Const sdName As String = "Sheet1"
Const sdFirst As String = "B2"
' Source Cities
Const scName As String = "Sheet1"
Const scFirst As String = "F9"
' Destination
Const dName As String = "Sheet2"
Const dFirst As String = "B2"
Dim wb As Workbook: Set wb = ThisWorkbook
' Source Dates
Dim sdws As Worksheet: Set sdws = wb.Worksheets(sdName)
Dim sdrg As Range: Set sdrg = sdws.Range(sdFirst).CurrentRegion
Dim sddrg As Range: Set sddrg = sdrg.Resize(sdrg.Rows.Count - 1).Offset(1)
Dim sdData As Variant: sdData = sddrg.Value
Dim sdrlrg As Range: Set sdrlrg = sddrg.Columns(1) ' Row Labels
' Source Cities
Dim scws As Worksheet: Set scws = wb.Worksheets(scName)
Dim scrg As Range: Set scrg = scws.Range(scFirst).CurrentRegion
Dim schRow As Long: schRow = scrg.Row ' Header Row
Dim scdrg As Range: Set scdrg = scrg.Resize(scrg.Rows.Count - 1).Offset(1)
Dim scrCount As Long: scrCount = scdrg.Rows.Count
Dim sccCount As Long: sccCount = scdrg.Columns.Count
' Destination Names
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfcell As Range: Set dfcell = dws.Range(dFirst)
Dim drg As Range: Set drg = dfcell.CurrentRegion.Columns(1)
Dim dnrg As Range: Set dnrg = drg.Resize(drg.Rows.Count - 1).Offset(1)
Dim dnData As Variant: dnData = dnrg.Value
' Destination Array
Dim drCount As Long: drCount = dnrg.Rows.Count
Dim dcCount As Long: dcCount = sdrg.Columns.Count
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
Dim scCell As Range
Dim dnValue As Variant
Dim scValue As Variant
Dim sdrIndex As Variant
Dim r As Long
Dim c As Long
For r = 1 To drCount
dnValue = dnData(r, 1)
If NoErrorNorBlank(dnValue) Then
Set scCell = Nothing
Set scCell = scdrg.Find(dnValue, _
scdrg.Cells(scrCount, sccCount), xlFormulas, xlWhole)
If Not scCell Is Nothing Then
scValue = scCell.EntireColumn.Rows(schRow).Value
If NoErrorNorBlank(scValue) Then
sdrIndex = Application.Match(scValue, sdrlrg, 0)
If IsNumeric(sdrIndex) Then
For c = 1 To dcCount
dData(r, c) = sdData(sdrIndex, c)
Next c
End If
End If
End If
End If
Next r
Set drg = dnrg.Offset(, 1).Resize(, dcCount)
drg.Value = dData
'wb.Save
End Sub
Function NoErrorNorBlank( _
ByVal CheckValue As Variant) _
As Boolean
If Not IsError(CheckValue) Then
If Len(CheckValue) > 0 Then
NoErrorNorBlank = True
End If
End If
End Function
This line is not identifying a district, but the name in the search itself. Change the statement to reference the data in line 9. I assume that position is fixed, if not then you need another approach.
Set currParamDict = rgFound.Offset(, 0)
' becomes
set currParamDict = Worksheets("sheet1").Cells(9, rgFound.Column)
I have a master sheet being updated by other workbooks. "Column A" in the Master has an ID number, the other spreadsheets will also have a column let's say "B" containing that ID number.
I want to match the ID number from the other workbook to the master and where it matches in column A pull over other columns into the master to fill in the blanks under the correct headings.
I was given this macro, but it's not matching any data.
Sub Macro1()
Dim mastersheet As Worksheet
Set mastersheet = ActiveSheet
For a = 2 To 1000
ValueToCheck = Cells(a, 1).Value
fname = "File location"
Dim Workbooktocheck As Workbook
Set Workbooktocheck = Workbooks.Open("filename")
For b = 2 To 1000
valueInNew = Workbooktocheck.Sheets("Sheet1").Cells(b, 12)
If ValueToCheck = valueInNew Then
mastersheet.Cells(a, 3).Value = Workbooktocheck.Sheets("sheet1").Cells(b, 7)
End If
Next b
Next a
End Sub
Update
This is the master:
This is the spreadsheet that updates:
Match() is usually faster than a nested loop as long as you're only expecting a single matched row.
Try this:
Sub Macro1()
Dim wsMaster As Worksheet, wbToCheck As Workbook, wsCheck As Worksheet
Dim ValueToCheck, a As Long, m
Set wsMaster = ActiveSheet
Set wbToCheck = Workbooks.Open("filepathgoeshere")
Set wsCheck = wbToCheck.Worksheets("Sheet1") '<<< was missing this
For a = 2 To wsMaster.Cells(Rows.Count, 1).End(xlUp).Row
ValueToCheck = wsMaster.Cells(a, 1).Value
If Len(ValueToCheck) > 0 Then
'match is faster than using a nested loop
m = Application.Match(ValueToCheck, wsCheck.Range("L:L"), 0)
If Not IsError(m) Then
'got a match
With wsMaster.Rows(a)
.Columns("C").Value = wsCheck.Cells(m, "G").Value
'etc for other cells...
End With
End If
End If
Next a
End Sub
Update Master Worksheet
Carefully adjust the values in the constants section.
s - Source (read from), d - Destination (written to)
Option Explicit
Sub UpdateMaster()
Const sPath As String = "C:\Test\Source.xlsx"
Const sName As String = "Sheet1"
Const sCol As String = "L"
Const sColsList As String = "A,B,C"
Const sfRow As Long = 1 ' header row
Const dName As String = "Master"
Const dCol As String = "A"
Const dfRow As Long = 1 ' header row
Dim swb As Workbook: Set swb = Workbooks.Open(sPath)
Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
' Headers
Dim sCols() As String: sCols = Split(sColsList, ",")
Dim cUpper As Long: cUpper = UBound(sCols)
Dim dCols() As Long: ReDim dCols(0 To cUpper)
Dim cIndex As Variant
Dim n As Long
For n = 0 To cUpper
cIndex = Application.Match( _
sws.Rows(sfRow).Columns(sCols(n)), dws.Rows(dfRow), 0)
If IsNumeric(cIndex) Then
dCols(n) = cIndex
Else
MsgBox "A header was not found", vbCritical, "Update Master"
Exit Sub
End If
Next n
' Column Ranges
Dim sfCell As Range: Set sfCell = sws.Cells(sfRow + 1, sCol)
Dim slCell As Range: Set slCell = sws.Cells(sws.Rows.Count, sCol).End(xlUp)
Dim srg As Range: Set srg = sws.Range(sfCell, slCell)
Dim dfCell As Range: Set dfCell = dws.Cells(dfRow + 1, dCol)
Dim dlCell As Range: Set dlCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp)
Dim drg As Range: Set drg = dws.Range(dfCell, dlCell)
' Write
Application.ScreenUpdating = False
Dim dCell As Range
Dim rIndex As Variant
For Each dCell In drg.Cells
rIndex = Application.Match(dCell.Value, srg, 0)
If IsNumeric(rIndex) Then
For n = 0 To cUpper
dCell.EntireRow.Columns(dCols(n)).Value _
= srg.Cells(rIndex).EntireRow.Columns(sCols(n)).Value
Next n
End If
Next dCell
Application.ScreenUpdating = True
' Inform
MsgBox "Data updated.", vbInformation, "Update Master"
End Sub