Check if value is in array then do - arrays

I have the following data:
The problem I'm trying to solve is that sometimes the Column H (Place) and Column I (Country) switch places (ex: lines 9,10,11). What I would like to do is:
First check if the year is within the last 3 years (I don't need to fix data older than that).
Load a range of values into an array.
Compare if the values in Column H are in the array.
If not, then switch values between columns. I did that by simply copying and pasting.
I'm stuck at this point. Sorry if it's ugly, first time dealing with arrays
The list I load into the array is in one workbook and the data is on another workbook. Does it work or they need to be on the same workbook?
Sub check_data()
Sheets("list").Activate 'this workbook
Dim DirArray As Variant
DirArray = Range("a1:a18").Value 'loads the range into an array
mypath = "//mynetworkpath/" 'sets the path
file = Dir(mypath & "filename.csv") 'indicates name of the file
Workbooks.Open (mypath & file) 'opens the file
Dim lastrow As Long
lastrow = Cells(Rows.Count, 2).End(xlUp).Row 'sorting by year
Range("A2:K" & lastrow).Sort key1:=Range("B2:B" & lastrow), _
order1:=xlDescending, Header:=xlNo
end_year = Format(Now, "yyyy") - 3 ' last 3 years
x = 2 'starts from second row
Do Until Cells(x, 2) = end_year 'cells(row,col)
For y = LBound(DirArray) To UBound(DirArray)
If Sheet1.Cells(x, 8) = DirArray(y) Then
Range("H" & x).Select
Selection.Copy
Range("M" & x).Select
ActiveSheet.Paste
Range("I" & x).Select
Application.CutCopyMode = False
Selection.Copy
Range("H" & x).Select
ActiveSheet.Paste
Range("M" & x).Select
Application.CutCopyMode = False
Selection.Copy
Range("I" & x).Select
ActiveSheet.Paste
Exit For
End If
Next
x = x + 1
Loop
ActiveWorkbook.Save
ActiveWorkbook.Close True
End Sub
Any guidance is helpful!
Thanks

You can leave the list on the worksheet and use match to check the values:
Sub check_data()
Const FPATH As String = "\\mynetworkpath\" 'use Const for fixed values
Dim rngVals As Range, wb As Workbook, lastrow As Long
Dim ws As Worksheet, tmp, file
Set rngVals = ThisWorkbook.Sheets("list").Range("a1:a18") 'your lookup list
file = Dir(FPATH & "filename.csv")
If Len(file) > 0 Then
Set wb = Workbooks.Open(FPATH & file) 'opens the file
Set ws = wb.Worksheets(1)
lastrow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
ws.Range("A2:K" & lastrow).Sort key1:=ws.Range("B2:B" & lastrow), _
order1:=xlDescending, Header:=xlNo
end_year = Year(Now) - 3 ' last 3 years
x = 2 'starts from second row
Do Until Cells(x, 2) = end_year 'cells(row,col)
tmp = ws.Cells(x, 8).Value
'use Match to check the value against the list
m = Application.Match(tmp, rngVals, 0)
If Not IsError(m) Then
'got a match, so swap the values from H and I
ws.Cells(x, 8).Value = ws.Cells(x, 9).Value
ws.Cells(x, 9).Value = tmp
End If
x = x + 1
Loop
wb.Save
wb.Close
End If 'got the file
End Sub

Related

Using VBA arrays to synchronize three sheets into one

I managed to sync selected data from three sheets into a fourth sheet. But the data doesn't align properly after empty cells beginning with the 14th row.
Now I'm trying to use arrays to align my data better. I have 3 sheets with columns Area, Zone, Employee and 6 numeric columns for each employee.
The data in Area, Zone & Employee is repeating itself in multiple rows so I need to add the numbers for every employee to have the Employee Name displayed only once with added data in other 6 columns.
I don't really have problem with filtering the names and adding data, but I'm not sure how to do it using arrays.
Or if anyone could help me find a mistake in my code that's causing the data to not align properly, I would also appreciate it. Below is my code so far, hopefully it would help.
Private Sub cmd_button1_Click()
Dim WS1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Set WS1 = Sheets("Sheet2")
Set ws2 = Sheets("Distribution")
Set ws3 = Sheets("Sheet3")
Set ws4 = Sheets("Sheet4")
Dim LastRow As Long
Dim R As Long, LR As Long, n As Long
Application.ScreenUpdating = False
'Getting the row number of last cell
LastRow = ws2.Range("A" & Rows.Count).End(xlUp).Row
'Deleting any previous data from destination sheet
ws2.Range("A2:AX10000").ClearContents
For i = 1 To 10
'If value in V column of the row is "" then copy the row to destination sheet
If WS1.Cells(i, "V").Value = "" Then
WS1.Range("E:E").Copy Destination:=ws2.Range("A1")
WS1.Range("F:F").Copy Destination:=ws2.Range("B1")
WS1.Range("G:G").Copy Destination:=ws2.Range("C1")
WS1.Range("A:A").Copy Destination:=ws2.Range("E1")
WS1.Range("O:O").Copy Destination:=ws2.Range("F1")
WS1.Range("P:P").Copy Destination:=ws2.Range("G1")
WS1.Range("R:R").Copy Destination:=ws2.Range("H1")
WS1.Range("S:S").Copy Destination:=ws2.Range("I1")
WS1.Range("Q:Q").Copy Destination:=ws2.Range("J1")
WS1.Range("T:T").Copy Destination:=ws2.Range("K1")
ws3.Range("E:E").Copy Destination:=ws2.Range("L1")
ws3.Range("F:F").Copy Destination:=ws2.Range("M1")
ws3.Range("G:G").Copy Destination:=ws2.Range("N1")
ws3.Range("A:A").Copy Destination:=ws2.Range("O1")
ws3.Range("S:S").Copy Destination:=ws2.Range("P1")
ws3.Range("T:T").Copy Destination:=ws2.Range("Q1")
ws3.Range("V:V").Copy Destination:=ws2.Range("R1")
ws3.Range("W:W").Copy Destination:=ws2.Range("S1")
ws3.Range("X:X").Copy Destination:=ws2.Range("T1")
ws4.Range("F:F").Copy Destination:=ws2.Range("U1")
ws4.Range("G:G").Copy Destination:=ws2.Range("V1")
ws4.Range("H:H").Copy Destination:=ws2.Range("W1")
ws4.Range("A:A").Copy Destination:=ws2.Range("X1")
ws4.Range("L:L").Copy Destination:=ws2.Range("Y1")
ws4.Range("M:M").Copy Destination:=ws2.Range("Z1")
ws4.Range("N:N").Copy Destination:=ws2.Range("AA1")
ws4.Range("O:O").Copy Destination:=ws2.Range("AB1")
ws4.Range("P:P").Copy Destination:=ws2.Range("AC1")
ws4.Range("Q:Q").Copy Destination:=ws2.Range("AD1")
End If
Next i
LR = Cells(Rows.Count, "C").End(xlUp).Row
Range("A2:AX" & LR).Sort Key1:=Range("A2"), Order1:=xlAscending
For R = 2 To LR
'Count the number of duplicates for third row
n = Application.CountIf(Columns(3), Cells(R, 3).Value)
'Sum up the values for every duplicate
Range("F" & R).Value = Evaluate("=Sum(F" & R & ":F" & R + n - 1 & ")")
Range("G" & R).Value = Evaluate("=Sum(G" & R & ":G" & R + n - 1 & ")")
Range("H" & R).Value = Evaluate("=Sum(H" & R & ":H" & R + n - 1 & ")")
Range("I" & R).Value = Evaluate("=Sum(I" & R & ":I" & R + n - 1 & ")")
Range("J" & R).Value = Evaluate("=Sum(J" & R & ":J" & R + n - 1 & ")")
Range("K" & R).Value = Evaluate("=Sum(K" & R & ":K" & R + n - 1 & ")")
Range("E" & R).Value = Evaluate("=Count(E" & R & ":E" & R + n - 1 & ")")
'Go to next value in third column
R = R + n - 1
Next R
On Error Resume Next
'Remove all duplicates
ws2.Range("$A$1:$K$7979").RemoveDuplicates Columns:=3, Header:=xlYes
On Error GoTo 0
'Fill out the table with values
Columns("A:K").AutoFit
Application.ScreenUpdating = True
Range("A1").Select
End Sub
The code above is for synchronizing the sheets with Distribution and filter the data from Sheet2, and I have 2 more buttons made to filter the other 2 sheets.
The code below is my attempt to align the data but it's not working correctly.
Sub LineEmUp()
Dim i As Long, j As Long, LR As Long
Application.ScreenUpdating = False
LR = Range("C" & Rows.Count).End(xlUp).Row
Columns("A:K").Sort Key1:=Range("A2"), _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Columns("L:T").Sort Key1:=Range("L2"), _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Columns("U:AD").Sort Key1:=Range("U2"), _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
i = 2
Do
If Cells(i, "C") > Cells(i, "N") And Cells(i, "C") > "" Then
Cells(i, "A").Resize(1, 10).Insert xlShiftDown
ElseIf Cells(i, "N") > Cells(i, "W") And Cells(i, "N") > "" Then
Cells(i, "L").Resize(1, 10).Insert xlShiftDown
ElseIf Cells(i, "W") > Cells(i, "C") And Cells(i, "W") > "" Then
Cells(i, "U").Resize(1, 10).Insert xlShiftDown
ElseIf Cells(i, "C") < Cells(i, "N") And Cells(i, "C") > "" Then
Cells(i, "L").Resize(1, 10).Insert xlShiftDown
ElseIf Cells(i, "N") < Cells(i, "W") And Cells(i, "N") > "" Then
Cells(i, "U").Resize(1, 10).Insert xlShiftDown
ElseIf Cells(i, "W") < Cells(i, "C") And Cells(i, "W") > "" Then
Cells(i, "A").Resize(1, 10).Insert xlShiftDown
End If
i = i + 1
Loop Until Cells(i, "C") = "" And Cells(i, "W") = ""
Application.ScreenUpdating = True
End Sub
Hope I explained it properly. Thanks
Organization (without unnecessary repetition) is always important in coding, and especially key when troubleshooting. For example, your 29 copy-paste statements can be tidied up considerably - which shows some inconsistencies.
...I sorted them by source worksheet and then by source column, and grouped them together, also pasting into columns instead of single cells.
Edit:
There's a number of "weird things" going on here that require some explanation so I know whether they're designed this way intentionally.
**See my "'<<<<<<" notes below (There are some specific questions, starting with *what happens if you don't disable screen updating, and don't ignore the errors with On Error Resume Next...?
Option Explicit
Private Sub cmd_button1_Click()
Dim WS1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Set WS1 = Sheets("Sheet2")
Set ws2 = Sheets("Distribution")
Set ws3 = Sheets("Sheet3")
Set ws4 = Sheets("Sheet4")
'Dim LastRow As Long
Dim R As Long, LR As Long, n As Long, i As Integer
' <<<<< always ALLOW screen updating during troubleshooting, until your code
' <<<<< is functioning perfectly: It may give a clue to the problem.
'Application.ScreenUpdating = False
'Getting the row number of last cell '<<<<< variable [LastRow] is not being used.
'LastRow = ws2.Range("A" & Rows.Count).End(xlUp).Row
'Deleting any previous data from destination sheet
'ws2.Range("A2:AX10000").ClearContents
ws2.UsedRange.ClearContents ' <<<<<< instead of specifying a range, just clear what's used
For i = 1 To 10
'If value in V column of the row is "" then copy the row to destination sheet
If WS1.Cells(i, "V").Value = "" Then
WS1.Range("A:A").Copy Destination:=ws2.Range("E:E") '<<< there's no pattern to what's being copied,
WS1.Range("E:G").Copy Destination:=ws2.Range("A:C") '<<< (and in a strange criss-cross),
WS1.Range("O:S").Copy Destination:=ws2.Range("F:I") '<<< are you sure nothing's being missed?
WS1.Range("T:T").Copy Destination:=ws2.Range("K:K")
ws3.Range("A:A").Copy Destination:=ws2.Range("O:O")
ws3.Range("E:G").Copy Destination:=ws2.Range("L:N")
ws3.Range("S:T").Copy Destination:=ws2.Range("P:Q")
ws3.Range("V:X").Copy Destination:=ws2.Range("R:T")
ws4.Range("A:A").Copy Destination:=ws2.Range("X1")
ws4.Range("F:H").Copy Destination:=ws2.Range("U:W")
ws4.Range("L:Q").Copy Destination:=ws2.Range("Y:AD")
End If
Next i
LR = Cells(Rows.Count, "C").End(xlUp).Row
Range("A2:AX" & LR).Sort Key1:=Range("A2"), Order1:=xlAscending '<<<<< this could be a problem??
For R = 2 To LR
'Count the number of duplicates for third row
n = Application.CountIf(Columns(3), Cells(R, 3).Value)
'Sum up the values for every duplicate
Range("F" & R).Value = Evaluate("=Sum(F" & R & ":F" & R + n - 1 & ")") '<<<<<< this is a strange way to do this...,
Range("G" & R).Value = Evaluate("=Sum(G" & R & ":G" & R + n - 1 & ")") '<<<<<< can you explain the purpose of these lines?
Range("H" & R).Value = Evaluate("=Sum(H" & R & ":H" & R + n - 1 & ")") '<<<<<< why not just add the cells normally instead like this?
Range("I" & R).Value = Evaluate("=Sum(I" & R & ":I" & R + n - 1 & ")")
Range("J" & R).Value = Evaluate("=Sum(J" & R & ":J" & R + n - 1 & ")")
Range("K" & R).Value = Evaluate("=Sum(K" & R & ":K" & R + n - 1 & ")")
Range("E" & R).Value = Evaluate("=Count(E" & R & ":E" & R + n - 1 & ")")
'Go to next value in third column
R = R + n - 1 '<<<<< WOAH! don't change the value of R when it's being used inside a loop!!!
Next R
'On Error Resume Next '<<<<< Errors mean something - Don't ignore them! (especially during troubleshooting)
'Remove all duplicates
ws2.Range("$A$1:$K$7979").RemoveDuplicates Columns:=3, Header:=xlYes '<<< this shifts cells around, might be a problem
On Error GoTo 0
'Fill out the table with values
Columns("A:K").AutoFit
Application.ScreenUpdating = True
Range("A1").Select
End Sub

How to refresh a Loop or update a Loop in VBA

So I have this list that is X rows long.
Each has 5 columns: Equipment, Type, Material, Size and Price this is in the Sheet2.
I also have a database in sheet1 with the same column filled in. I have written a code in VBA that for each row in Sheet2 I can fill in Equipment, Type, Material and Size and it will search in the database in sheet1 the matching price for those criteria and past this under the column Price in Sheet2.
Now the problem that I have is if I for example filled in row 1, row 2 and row 3 after each other it works and gives me the price but if I later want to change the variables in row 1 or 2 it doesn't change/update the Price but it still works for row 3 and forward.
How do I make it so that it does change/Update the price in row 1 and 2 if I change the variables there.
my code:
Option Explicit
Public r As Long
Public Const adOpenStatic = 3
Public Const adOpenKeySet = 1
Public Const adLockReadOnly = 1
Sub cmdSearch_Click()
Dim strCriteriaEquipment As String
Dim strCriteriaType As String
Dim strCriteriaMaterial As String
Dim strCriteriaSize As String
Dim strSQL As String
Dim strSourceTable As String
Dim c As Long, LR As Long
LR = Cells(Rows.Count, 2).End(xlUp).Row
For r = 1 To LR
c = 2
With Worksheets("Summary")
strCriteriaEquipment = Worksheets("Summary").Cells(r, c).Value
strCriteriaType = Worksheets("Summary").Cells(r, c + 1).Value
strCriteriaMaterial = Worksheets("Summary").Cells(r, c + 2).Value
strCriteriaSize = Worksheets("Summary").Cells(r, c + 3).Value
End With
Next r
strSourceTable = "[DB$" & Replace(Worksheets("DB").Range("SourceData").Address, "$", "") & "]"
strSQL = "SELECT [Price] FROM " & strSourceTable & vbNewLine
strSQL = strSQL & "WHERE [Equipment]= """ & strCriteriaEquipment & """" & vbNewLine
strSQL = strSQL & "AND [Type]=""" & strCriteriaType & """" & vbNewLine
strSQL = strSQL & "AND [Material]=""" & strCriteriaMaterial & """" & vbNewLine
strSQL = strSQL & "AND [Size]=""" & strCriteriaSize & """;"
Dim rstRecordSet As Object 'ADODB.Recordset
Dim con As Object 'ADODB.Connection
Dim strWorkBookPath As String
strWorkBookPath = ThisWorkbook.FullName
Set con = CreateObject("ADODB.Connection")
Set rstRecordSet = CreateObject("ADODB.RecordSet")
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strWorkBookPath & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
rstRecordSet.Open strSQL, con, adOpenStatic, adLockReadOnly
With Worksheets("Summary")
For r = r - 29 To LR
c = 5
If Not (rstRecordSet.EOF And rstRecordSet.BOF) Then
.Range("ResultTable").Cells(r, c).CopyFromRecordset rstRecordSet
Else
.Range("ResultTable").Cells(r, c).Value = "Data Not Found!"
End If
Next r
End With
rstRecordSet.Close
con.Close
Set rstRecordSet = Nothing
Set con = Nothing
strWorkBookPath = vbNullString
strSQL = vbNullString
strCriteriaEquipment = vbNullString
strCriteriaType = vbNullString
strCriteriaMaterial = vbNullString
strCriteriaSize = vbNullString
strSourceTable = vbNullString
End Sub
Public Function UniqueStringWithDelimiter(varArray As Variant, strDelimiter As String) As Variant
Dim varTemp() As Variant
Dim lngLoop As Long
Dim strConcat As String
ReDim Preserve varTemp(0 To 0)
varTemp(0) = varArray(0, 0)
strConcat = strConcat & varArray(0, 0)
For lngLoop = 1 To UBound(varArray, 2)
If InStr(1, strConcat, varArray(0, lngLoop), vbTextCompare) = 0 Then
strConcat = strConcat & strDelimiter & varArray(0, lngLoop)
End If
Next lngLoop
UniqueStringWithDelimiter = strConcat.
strConcat = vbNullString
Erase varTemp
End Function
Now to update everytime I change something in Sheet2 I just wrote this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call cmdSearch_Click
End Sub
So again my question how do I update/change the price if I change a variable in row 1 or row 2 if row 3 was the last row that was used in the sheet.
This is the datbase that I am using:
This is Sheet2:
1) One immediate problem I see that will cause your issue (and there may be more, but I don't have time to dissect so much at this moment), is that the initial loop:
For r = 1 To LR
c = 2
With Worksheets("Summary")
strCriteriaEquipment = Worksheets("Summary").Cells(r, c).Value
strCriteriaType = Worksheets("Summary").Cells(r, c + 1).Value
strCriteriaMaterial = Worksheets("Summary").Cells(r, c + 2).Value
strCriteriaSize = Worksheets("Summary").Cells(r, c + 3).Value
End With
Next r
is not doing what you may expect. At the end of this loop you only have set the values for the last row of data (I suspect row 3) to pass into your query.
You'll need to write your queries inside this loop as well so that the query is run for each set of criteria in each line.
For example:
For r = 1 to LR
c = 2
With Worksheets("Summary")
'code to set criteria
End With
'code to download data price
'code to stick data and price in summary tab
Next r
2) Also, make sure to qualify all your objects. The line
LR = Cells(Rows.Count, 2).End(xlUp).Row
may return different results if the sheet you desire to be active is not actually active. Better to say this, for example, and leave out guess works:
LR = Worksheets("Summary").Cells(Rows.Count, 2).End(xlUp).Row
3) Using Worksheet_SelectionChange will fire your code every time you move from one to another in your worksheet. If you want to only fire the code when you make a change to the criteria in your data, use Worksheet_Change instead. You can also define which specific cells being changes will run the code as well.

VBA Error Upon updating Worksheet in active Workbook from identical Worksheet in other Workbook

A VBA-newby is in need of help.
I am trying to enable users of my Project to update their Excel-file from another, identical file. The data can include every type of data, including links.
However, I run into two Problems:
(1) When reaching a certain cell including a link to an external file, I get a Runtime Error 13: Type Mismatch.
(2) At some points in my table, the header gets copied down, in others not.
I am relatively new to VBA and don't know where my mistakes are. Any help to reach my Goal would be greatly appreciated!
Application.ScreenUpdating = False
Dim wbInput As Workbook
Dim wbOutput As Workbook
Set wbOutput = ActiveWorkbook
Dim wsOutputDB As Worksheet
Set wsOutputDB = wbOutput.Worksheets("Meta DB")
Dim wsOutputCriteria As Worksheet
Set wsOutputCriteria = wbOutput.Worksheets("Criteria")
Dim wsOutputSkills As Worksheet
Set wsOutputSkills = wbOutput.Worksheets("Supplier Skills")
Dim strInput As String
Dim ID As Range
Dim IDcolumn As Range
Dim FindID As Range
Dim FindChange
Dim lRowInput As Integer
Dim lRowOutput As Integer
Dim NextRow As Integer
Dim lastcol As Integer
Dim lastcolOutput As Integer
Dim HeaderColumn As Range
Dim FindNewColItem As Range
strInput = Application.GetOpenFilename()
Set wbInput = Workbooks.Open(strInput)
wbInput.Worksheets("Meta DB").Visible = True
lRowInput = wbInput.Worksheets("Meta DB").Range("D" & Rows.Count).End(xlUp).row
lRowOutput = wsOutputDB.Range("D" & Rows.Count).End(xlUp).row
NextRow = wsOutputDB.Range("D" & Rows.Count).End(xlUp).row + 1
'1.0. - - ######################Copy all missing DB-Entries####################
With wbInput.Worksheets("Meta DB")
lastcol = .Cells(3, Columns.Count).End(xlToLeft).Column
LastColLetter = Split(wbInput.Worksheets("Meta DB").Cells(3, lastcol).Address, "$")(1)
lastcolOutput = wsOutputDB.Cells(3, Columns.Count).End(xlToLeft).Column
'1.1. - - Check if any new Variables have been added
For Each HeaderColumn In .Range("B3:" & LastColLetter & "3")
Set FindNewColItem = wsOutputDB.Range("B3:" & LastColLetter & "3").Find(What:=HeaderColumn, LookAt:=xlWhole)
If FindNewColItem Is Nothing Then
NewColLetter = Split(HeaderColumn.Address, "$")(1)
NextCol = lastcolOutput + 1
wbInput.Worksheets("Meta DB").Range(NewColLetter & "3").Copy Destination:=wsOutputDB.Range(NewColLetter & "3")
NextCol = NextCol + 1
End If
Next HeaderColumn
'1.2. - - Check if there are any new Entries to the Database
For Each ID In .Range("D4:D" & lRowInput)
Set FindID = wsOutputDB.Range("D4:D" & lRowOutput).Find(What:=ID, LookIn:=xlValues, LookAt:=xlWhole)
'1.2.1. - - If ID is a new Entry, simply add it to our file, else...
If FindID Is Nothing Then
NewIDrow = Split(ID.Address, "$")(2)
wbInput.Worksheets("Meta DB").Range("B" & NewIDrow & ":" & LastColLetter & NewIDrow).Copy Destination:=wsOutputDB.Range("B" & NextRow & ":" & LastColLetter & NextRow)
NextRow = NextRow + 1
Else
'1.2.2. - - If ID already exists, check for Updates of any Information
For Each IDcolumn In .Range("B" & ID.row & ":" & LastColLetter & ID.row)
Set FindChange = wsOutputDB.Range("B" & FindID.row & ":" & LastColLetter & FindID.row).Find(What:=IDcolumn)
If FindChange Is Nothing Then
ColLetter = Split(IDcolumn.Address, "$")(1)
wbInput.Worksheets("Meta DB").Range(ColLetter & ID.row).Copy Destination:=wsOutputDB.Range(ColLetter & FindID.row)
End If
Next IDcolumn
End If
Next ID
End With

Optimize this VBA lookup loop in Excel

I want to optimize the following code, as it is very slow.
I am using the code found in this answer:
https://stackoverflow.com/a/27108055/1042624
However, it is very slow when looping through +10k rows. Is it possible to optimize my code below? I have tried to modify it a bit, but it does not seem to work.
Sub DeleteCopy2()
Dim LastRow As Long
Dim CurRow As Long
Dim DestLast As Long
Dim strSheetName As String
Dim arrVal() As Long
Application.ScreenUpdating = False
Application.Calculation = xlManual
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
LastRow = Sheets("MatchData").Range("A" & Rows.Count).End(xlUp).Row
DestLast = Sheets(strSheetName).Range("A" & Rows.Count).End(xlUp).Row
ReDim arrVal(2 To LastRow) ' Headers in row 1
For CurRow = LBound(arrVal) To UBound(arrVal)
If Not Sheets(strSheetName).Range("A2:A" & DestLast).Find(Sheets("MatchData").Range("A" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
Sheets("MatchData").Range("A" & CurRow).Value = ""
Else
End If
Next CurRow
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Can you try this for me? I have commented the code so that you will not have a problem understanding it. Also check how much time it takes for 10k+ rows
Logic
Store search values in array 1
Store destination values in array 2
Loop through the first array and check if it is present in the second array. If present, clear it
Clear the search values from sheet1
Output the array to the sheet1
Sort Col A so that the blanks go down.
Code
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long, i As Long
Dim MArr As Variant, DArr As Variant
Dim strSheetName As String
Dim rng As Range
strSheetName = "Sheet2" '"Week " & IsoWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A2:A" & lRow)
MArr = rng.Value
End With
'~~> Store destination values in the 2nd array
With wbDestSheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
DArr = .Range("A2:A" & lRow).Value
End With
'~~> Check if the values are in the other array
For i = LBound(MArr) To UBound(MArr)
If IsInArray(MArr(i, 1), DArr) Then MArr(i, 1) = ""
Next i
With wbMatch
'~~> Clear the range for new output
rng.ClearContents
'~~> Output the array to the worksheet
.Range("A2").Resize(UBound(MArr), 1).Value = MArr
'~~> Sort it so that the blanks go down
.Columns(1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
End Sub
'~~> function to check is a value is in another array
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim j As Long
For j = 1 To UBound(arr, 1)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Function
Edit
Another way. Based on the sample file, this code runs in approx 1 minute.
Start : 8/4/2016 08:59:36 PM
End : 8/4/2016 09:00:47 PM
Logic:
It uses CountIf to check for duplicates and then deletes the duplicates using .Autofilter
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long
Dim strSheetName As String
Dim rng As Range
Debug.Print "Start : " & Now
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Columns(2).Insert
Set rng = .Range("B2:B" & lRow)
lRow = wbDestSheet.Range("A" & wbDestSheet.Rows.Count).End(xlUp).Row
rng.Formula = "=COUNTIF('" & strSheetName & "'!$A$1:$A$" & lRow & ",A2)"
DoEvents
rng.Value = rng.Value
.Range("B1").Value = "Temp"
'Remove any filters
.AutoFilterMode = False
With .Range("A1:E" & lRow) 'Filter, offset(to exclude headers) and delete visible rows
.AutoFilter Field:=2, Criteria1:=">0"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'Remove any filters
.AutoFilterMode = False
.Columns(2).Delete
End With
Debug.Print "End : " & Now
End Sub
Looks like #SiddarthRout and I were working in parallel...
My code example below executes in less than 2 secs (eyeball estimate) over almost 12,000 rows.
Option Explicit
Sub DeleteCopy2()
Dim codeTimer As CTimer
Set codeTimer = New CTimer
codeTimer.StartCounter
Dim thisWB As Workbook
Dim destSH As Worksheet
Dim matchSH As Worksheet
Set thisWB = ThisWorkbook
Set destSH = thisWB.Sheets("Week 32")
Set matchSH = thisWB.Sheets("MatchData")
Dim lastMatchRow As Long
Dim lastDestRow As Long
lastMatchRow = matchSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
lastDestRow = destSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
'--- copy working data into memory arrays
Dim destArea As Range
Dim matchData As Variant
Dim destData As Variant
matchData = matchSH.Range("A1").Resize(lastMatchRow, 1)
Set destArea = destSH.Range("A1").Resize(lastDestRow, 1)
destData = destArea
Dim i As Long
For i = 2 To lastDestRow
If Not InMatchingData(matchData, destData(i, 1)) Then
destData(i, 1) = ""
End If
Next i
'--- write the marked up data back to the worksheet
destArea = destData
Debug.Print "Destination rows = " & lastDestRow
Debug.Print "Matching rows = " & lastMatchRow
Debug.Print "Execution time = " & codeTimer.TimeElapsed & " secs"
End Sub
Private Function InMatchingData(ByRef dataArr As Variant, _
ByRef dataVal As Variant) As Boolean
Dim i As Long
InMatchingData = False
For i = LBound(dataArr) To UBound(dataArr)
If dataVal = dataArr(i, 1) Then
InMatchingData = True
Exit For
End If
Next i
End Function
The timing results from my code are (using the timer class from this post ):
Destination rows = 35773
Matching rows = 23848
Execution time = 36128.4913359179 secs

Activate windows of files stored in arrays, but getting subscript out of range error?

Sub Merge()
Dim File As String
Dim AllFiles(), Filename As Variant
Dim count, test, StartRow, LastRow, LastColumn As Long
Dim LastCell As Variant
test = 0
ChDir "C:\" 'Insert suitable directory for your computer ex:ChDir "C:\Users\Jerry Hou\" if file of interest is in "Jerry Hou" Folder
ReDim AllFiles(1)
Do
Application.EnableCancelKey = xlDisabled
File = Application.GetOpenFilename("XML Files (*.xml),*.xml", 1, "Select File to be Merged") 'Needs to select in Order to merge files
Application.EnableCancelKey = xlErrorHandler
If (File = "False") Then Exit Do
ReDim Preserve AllFiles(count) 'Preserve ?
AllFiles(count) = File 'File== file name and directory
count = (count + 1)
If (MsgBox("Select Another File To be Merged With?", vbQuestion + vbOKCancel, "Merge Files") = vbCancel) Then Exit Do
Loop 'Select Cancel in MsgBox to finish merge file(s) selection
If (count = 0) Then
MsgBox "No selection" 'If you hit Exit from open prompt window
Exit Sub
End If
For count = 0 To UBound(AllFiles)
MsgBox "User selected file name: " & AllFiles(count)
Next
test = count
For test = UBound(AllFiles) To LBound(AllFiles) Step -1
Workbooks.Open Filename:=AllFiles(test)
Next
ReDim AllFiles(count)
test = 2
Do While (test <= count)
Filename = AllFiles(test)
Workbooks(AllFiles(test)).Activate 'ERROR Brings 2nd file that the user had selected to Last xml file selected in order to Front
'Copy and Paste TMG tab
Sheets("TMG_4 0").Activate
StartRow = 2
LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastColumn = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastCell = Cells(LastRow, LastColumn).Address 'Find lastcell of to be copied file
Range("A2:" & LastCell).Select
Selection.Copy
Windows("Allfiles(1).xml").Activate 'ERROR
Sheets("TMG_4 0").Activate
LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRow = LastRow + 1
Range("LastRow").Select 'ERROR
ActiveSheet.Paste
'Copy and Paste Gamma tab
Sheets("GammaCPS 0").Activate
StartRow = 2
LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastColumn = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastCell = Cells(LastRow, LastColumn).Address
Range("A2:" & LastCell).Select
Selection.Copy
Windows("Allfiles(1).xml").Activate 'ERROR Windows("File_name.xlsm").activate
Sheets("GammaCPS 0").Activate
LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRow = LastRow + 1
Range("LastRow").Select 'ERROR
ActiveSheet.Paste
test = test + 1
Loop
Windows("Allfiles(1).xml").Activate 'ERROR
ActiveWorkbook.SaveAs Filename:="C:\" & AllFiles(1) & AllFiles(test) & ".xlsm", FileFormat:=52
End Sub
You redim AllFiles but never fill it with anything. Is there missing code?
AllFiles is a 0 based array so if you want to start at the second element you need to use test = 1 instead of test = 2.
For looping through an array, try this:
For test = 1 to ubound(AllFiles) - 1 'This loops through the array from the second element to the last
Is "LastRow" a named range? If not, that's not going to work. The following will select the last used row in a worksheet:
activesheet.Rows(activesheet.usedrange.rows.count).select
Your SaveAs is failing because 1) AllFiles looks like it's never filled and 2) your save path as you wrote would be literally: C:\Allfile(1)&Allfiles(count)\.xlsm. You want:
ActiveWorkbook.SaveAs Filename:= "C:\" & AllFiles(1) & AllFiles(test) & ".xlsm"
EDIT After Code Update
You never initialize your count variable, add count = 0 to the beginning just to be safe.
GetOpenFilename does in fact return the full path. Once you have that path stored in a variable (such as AllFiles()) you can get just the filename portion with mid(AllFiles(test), instrrev(AllFiles(test), "\") + 1)
You don't need the ReDim AllFiles(count) prior to your main Do Loop. ReDim erases the contents of the array unless you use the Preserve keyword.
Change Workbooks(AllFiles(test)).Activate to Workbooks(Mid(AllFiles(test), InStrRev(AllFiles(test), "\") + 1)).Activate to strip the path information and leave just the filename.
Windows("Allfiles(1).xml").Activate won't work since your sending a literal string. You want WORKBOOKS(Mid(AllFiles(1), InStrRev(AllFiles(1), "\") + 1)).Activate here again.
LastRow = LastRow + 1 probably isn't what you meant. Try Set LastRow = LastRow.Offset(1, 0)
Change Range("LastRow").Select to LastRow.select
All instances of Windows( should be changed to Workbooks(

Resources