Macro to combine daily extract to existing worksheet

[13373]

I need to export a spreadsheet daily and combine it with an existing spreadsheet for tracking.

What I need to accomplish is a macro that will run a check on the new worksheet (Export) and existing worksheet (Sheet1) to combine them, marking all items that are not present on the Export as complete on Sheet1 and adding any new items from the Export to Sheet1. Every line has a unique identifier (ItemID) so I am guessing that the best way to accomplish this would be with a v-lookup using this, however my experience with this in a macro is very limited. I only need to extract information from specific columns from the Export, and the columns don't line up, also there are never a set number of lines on either worksheet.

On the Sheet1 I have 19 columns with A being ItemID. On the Export I have 13 columns with L being the ItemID.

If the ItemID on Sheet1 is no longer on the Export, an "X" needs to be put in Column S (Completed) if one does not already exist.

If the ItemID on Sheet1 is still on the Export, however an "X" appears in the Completed column, highlight the line.

If the ItemID is not on Sheet1 create a new line and copy the information from the same line as the ItemID in the Export.

Copy from Export to Sheet1
Column L - Column A
Column A - Column E
Column B - Column F
Column D - Column G
Column E - Column H
Column F - Column J
Column G - Column K
Column J - Column L
Column K - Column M

I don't know if I am going about this the right way or if there is an easier way, any help would be greatly appreciated.

[alansidman]

In which column does the unique ID appear on the Export Sheet and in which column does the unique ID appear in Sheet1.

[13373]

Column A on Sheet1 and Column L on Export. Sorry if I didn't make that very clear, I was trying to convey any relevant information.

[xladept]

Hi,

Welcome to the forum - I'll have something for you tomorrow!

[xladept]

It's untested as there was no sample provided - but see if it works:

Sub ThirteenThree(): Dim w1 As Worksheet, we As Worksheet, e As Long, r As Long
Set w1 = Sheets("Sheet1"): Set we = Sheets("Export")
With CreateObject("Scripting.Dictionary")
For e = 1 To we.Range("L" & Rows.Count).End(xlUp).Row
ID = Range("L" & e): .Item(ID) = e: Next e
For r = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row: ID = Range("A" & r)
If Not .Exists(ID) Then
w1.Range("S" & r) = "X"
ElseIf w1.Range("S" & r) = "X" Then
w1.Range("S" & r).EntireRow.Interior.ColorIndex = 6
End If: Next r: End With
With CreateObject("Scripting.Dictionary")
For r = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row: ID = Range("A" & r)
.Item(ID) = r: Next r
For e = 1 To we.Range("L" & Rows.Count).End(xlUp).Row: ID = Range("L" & e)
If Not .Exists(ID) Then
w1.Range("A" & r) = we.Range("L" & e)
w1.Range("E" & r) = we.Range("A" & e)
w1.Range("F" & r) = we.Range("B" & e)
w1.Range("G" & r) = we.Range("D" & e)
w1.Range("H" & r) = we.Range("E" & e)
w1.Range("J" & r) = we.Range("F" & e)
w1.Range("K" & r) = we.Range("G" & e)
w1.Range("L" & r) = we.Range("J" & e)
w1.Range("M" & r) = we.Range("K" & e)
r = r + 1: End If: Next e: End With
End Sub

[13373]

As is, it marks all lines on Sheet1 as complete and adds all lines from Export including the header.

Due to the sensitive data, I cannot share the spreadsheet, however I will try and create a fake sheet for an example.

Thank you again for your time and effort.

[xladept]

I didn't know there was a header and I was thinking that the procedure should be run in reverse and, in case of discrepancies between sheets, I've added a little sanitizing of the ID's - try:

Sub ThirteenThree(): Dim w1 As Worksheet, we As Worksheet, e As Long, r As Long
Set w1 = Sheets("Sheet1"): Set we = Sheets("Export")

With CreateObject("Scripting.Dictionary")
For r = 2 To w1.Range("A" & Rows.Count).End(xlUp).Row
ID = Trim(LCase(Range("A" & r))): .Item(ID) = r: Next r
For e = 2 To we.Range("L" & Rows.Count).End(xlUp).Row
    ID = Trim(LCase(Range("L" & e)))
If Not .Exists(ID) Then
w1.Range("A" & r) = we.Range("L" & e)
w1.Range("E" & r) = we.Range("A" & e)
w1.Range("F" & r) = we.Range("B" & e)
w1.Range("G" & r) = we.Range("D" & e)
w1.Range("H" & r) = we.Range("E" & e)
w1.Range("J" & r) = we.Range("F" & e)
w1.Range("K" & r) = we.Range("G" & e)
w1.Range("L" & r) = we.Range("J" & e)
w1.Range("M" & r) = we.Range("K" & e)
r = r + 1: End If: Next e: End With

With CreateObject("Scripting.Dictionary")
For e = 2 To we.Range("L" & Rows.Count).End(xlUp).Row
ID = Trim(LCase(Range("L" & e))): .Item(ID) = e: Next e
For r = 2 To w1.Range("A" & Rows.Count).End(xlUp).Row
    ID = Trim(LCase(Range("A" & r)))
If Not .Exists(ID) Then
w1.Range("S" & r) = "X"
ElseIf w1.Range("S" & r) = "X" Then
w1.Range("S" & r).EntireRow.Interior.ColorIndex = 6
End If: Next r: End With

End Sub

[13373]

Sample Sheet.xlsm

It still appears to copy everything and marking everything complete.

I have attached a sample that is like what I am looking at.

Thank you again,

[xladept]

It lacked a little specificity - what about sheet2 and sheet3?

Sub ThirteenThree(): Dim w1 As Worksheet, we As Worksheet, e As Long, r As Long
Dim ID As String: Set w1 = Sheets("Sheet1"): Set we = Sheets("Export")

With CreateObject("Scripting.Dictionary")
For r = 2 To w1.Range("A" & Rows.Count).End(xlUp).Row
ID = Trim(LCase(w1.Range("A" & r))): .Item(ID) = r: Next r
For e = 2 To we.Range("L" & Rows.Count).End(xlUp).Row
    ID = Trim(LCase(we.Range("L" & e)))
If Not .Exists(ID) Then
w1.Range("A" & r) = we.Range("L" & e)
w1.Range("E" & r) = we.Range("A" & e)
w1.Range("F" & r) = we.Range("B" & e)
w1.Range("G" & r) = we.Range("D" & e)
w1.Range("H" & r) = we.Range("E" & e)
w1.Range("J" & r) = we.Range("F" & e)
w1.Range("K" & r) = we.Range("G" & e)
w1.Range("L" & r) = we.Range("J" & e)
w1.Range("M" & r) = we.Range("K" & e)
r = r + 1: End If: Next e: End With

With CreateObject("Scripting.Dictionary")
For e = 2 To we.Range("L" & Rows.Count).End(xlUp).Row
ID = Trim(LCase(we.Range("L" & e))): .Item(ID) = e: Next e
For r = 2 To w1.Range("A" & Rows.Count).End(xlUp).Row
    ID = Trim(LCase(w1.Range("A" & r)))
If Not .Exists(ID) Then
w1.Range("S" & r) = "X"
ElseIf w1.Range("S" & r) = "X" Then
w1.Range("S" & r).EntireRow.Interior.ColorIndex = 6
End If: Next r: End With

End Sub

[13373]

Sheet3 is nothing and doesn't need to be there. Sheet2 contains dropdowns for some of the columns in Sheet1.

That is really a thing of beauty, works great! I wish that I understood everything that took place, and I will try to, but it currently goes a bit above my head.

I honestly could not thank you enough, this is going to make life so much easier and the function of the spreadhseet more efficient. This was something we did once a month manually while archiving all competed items.

Thank you again.

[xladept]

So - Did it work??

[13373]

Yes - Yes it did!!

Sorry, I just edited my last post, should have posted a new one.

Works amazing and I greatly appreciate your help.

[xladept]

The Scripting Dictionary is a wonderful matching tool:

With CreateObject("Scripting.Dictionary") ‘Initializes a “dictionary”
'With this code we build the “Words”(ID’S) and their meanings(Rows)
For e = 2 To we.Range("L" & Rows.Count).End(xlUp).Row
ID = Trim(LCase(we.Range("L" & e))): .Item(ID) = e: Next e
'Now we scan the Sheet1 ID’S to see whether they match in the Exports
For r = 2 To w1.Range("A" & Rows.Count).End(xlUp).Row
    ID = Trim(LCase(w1.Range("A" & r)))
If Not .Exists(ID) Then  ‘I hope this code speaks for itself
w1.Range("S" & r) = "X"
ElseIf w1.Range("S" & r) = "X" Then
w1.Range("S" & r).EntireRow.Interior.ColorIndex = 6
End If: Next r: End With

[xladept]

You're welcome and thanks for both the compliment and for the rep!

[xladept]

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. Thanks.