All I'm trying to achieve here is to look at 2 data extracts (this weeks against last weeks) and highlight any deltas...
SO, what is on this weeks file that wasn't on last weeks - As they'll need creating/loading
and, what's on last weeks file that isn't on this weeks - As they'll need closing/de-activating
I've created a macro that first opens both sets of data and then correctly formats them ready for loading. I then use a loop to highlight the deltas as described above. I'll then just need to write the remaining of the code to drop the deltas onto an import file.
The problem is that my data sets are both over 100,000 rows
As you can imagine... it takes way too long!
Is there a quicker/more efficient method?
I've tried using formulas instead of the loop (e.g. insert a vlookup instead) but that obviously takes too long to calculate for a macro (doesn't finish calculating by the time the data wants to be moved)
The data I'm working with looks like this (all in column A, before my macro formats it and there's over 100K rows on both files):
[TABLE="width: 183"]
<tbody>[TR]
[TD]10A846|B0000101|B0000606
[/TD]
[/TR]
[TR]
[TD]10A846|B0001100|B0000606
[/TD]
[/TR]
[TR]
[TD]10A846|B0001109|B0000606
[/TD]
[/TR]
[TR]
[TD]10A846|B0001200|B0000606
[/TD]
[/TR]
[TR]
[TD]10A846|B0001209|B0000606
[/TD]
[/TR]
</tbody>[/TABLE]
The part of the code that's slow is this (full code below that)
The full code is:
Any help/suggestion really would be appreciated
Thanks
SO, what is on this weeks file that wasn't on last weeks - As they'll need creating/loading
and, what's on last weeks file that isn't on this weeks - As they'll need closing/de-activating
I've created a macro that first opens both sets of data and then correctly formats them ready for loading. I then use a loop to highlight the deltas as described above. I'll then just need to write the remaining of the code to drop the deltas onto an import file.
The problem is that my data sets are both over 100,000 rows
As you can imagine... it takes way too long!Is there a quicker/more efficient method?
I've tried using formulas instead of the loop (e.g. insert a vlookup instead) but that obviously takes too long to calculate for a macro (doesn't finish calculating by the time the data wants to be moved)
The data I'm working with looks like this (all in column A, before my macro formats it and there's over 100K rows on both files):
[TABLE="width: 183"]
<tbody>[TR]
[TD]10A846|B0000101|B0000606
[/TD]
[/TR]
[TR]
[TD]10A846|B0001100|B0000606
[/TD]
[/TR]
[TR]
[TD]10A846|B0001109|B0000606
[/TD]
[/TR]
[TR]
[TD]10A846|B0001200|B0000606
[/TD]
[/TR]
[TR]
[TD]10A846|B0001209|B0000606
[/TD]
[/TR]
</tbody>[/TABLE]
The part of the code that's slow is this (full code below that)
Code:
Dim searchvalue
For i = 1 To lastrow 'start in row 1 to last row
Set searchvalue = NewData.Range("B" & i) 'what to look for
With Olddata.Range("B1:B" & lastrow2) 'range to look in
Set c = .Find(searchvalue, LookIn:=xlValues) 'Find what im looking for in the range im looking in
If Not c Is Nothing Then 'if found
NewData.Cells(i, "D") = "Found"
Else 'if not found
NewData.Cells(i, "D") = "Not Found"
GoTo NEXTSEARCH1
End If
End With
NEXTSEARCH1:
Next IThe full code is:
Code:
Sub Macro1()
Dim lastrow As Long, lastrow2 As Long
Dim Toolbook As Workbook
Dim newbook As Workbook
Dim Oldbook As Workbook
Dim customerFilename As String
Dim filter As String
Set Toolbook = Application.ActiveWorkbook
Application.ScreenUpdating = False
'Open new data file and name 'newbook'
MsgBox "Please new data File"
filter = "Text files (*.csv*),*.csv*"
Caption = "File Select"
customerFilename = Application.GetOpenFilename(filter, , Caption)
Application.Workbooks.Open (customerFilename)
Set newbook = Application.ActiveWorkbook
'Open old data file and name 'oldbook'
MsgBox "Select previous data File"
filter = "Text files (*.csv*),*.csv*"
Caption = "File Select"
customerFilename = Application.GetOpenFilename(filter, , Caption)
Application.Workbooks.Open (customerFilename)
Set Oldbook = Application.ActiveWorkbook
' Set Sheet names
Dim Olddata As Worksheet
Set Olddata = Oldbook.Worksheets(1)
Dim NewData As Worksheet
Set NewData = newbook.Worksheets(1)
'row counts
lastrow = NewData.Cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = Olddata.Cells(Rows.Count, 1).End(xlUp).Row
NewData.Range("B1", "B" & lastrow).Value = "=Left(A1, 6)&Mid(A1, 8, 8)"
NewData.Range("C1", "C" & lastrow).Value = "=IF(ISNUMBER(LEFT(B1,1)*1)=TRUE,""1350-Project (CPA)"",""1350-Capital (CPA)"")"
Olddata.Range("B1", "B" & lastrow2).Value = "=Left(A1, 6)&Mid(A1, 8, 8)"
Olddata.Range("C1", "C" & lastrow2).Value = "=IF(ISNUMBER(LEFT(B1,1)*1)=TRUE,""1350-Project (CPA)"",""1350-Capital (CPA)"")"
'Check for deltas
Dim searchvalue
For i = 1 To lastrow 'start in row 1 to last row
Set searchvalue = NewData.Range("B" & i) 'what to look for
With Olddata.Range("B1:B" & lastrow2) 'range to look in
Set c = .Find(searchvalue, LookIn:=xlValues) 'Find what im looking for in the range im looking in
If Not c Is Nothing Then 'if found
NewData.Cells(i, "D") = "Found"
Else 'if not found
NewData.Cells(i, "D") = "Not Found"
GoTo NEXTSEARCH1
End If
End With
NEXTSEARCH1:
Next i
Application.ScreenUpdating = True
End SubThanks
