Problem: I am unable to define a range using a variable (i) and specific cells row (cell.Row).
Current Code:
Sub TaskSearch()
'Dim wb As Workbook
Dim oSht As Worksheet
Dim lastRow As Long, i As Long
Dim strSearch As String
Dim aCell As Range
ThisWorkbook.Sheets("Interface").Range("D19:D33").ClearContents
'Set wb = Workbooks.Open("H:\Kevin.Boots\Database.xlsx")
Set oSht = Sheets("TaskMaster")
lastRow = oSht.Range("A" & Rows.Count).End(xlUp).Row
strSearch = Sheets("Interface").Range("F5")
Set aCell = oSht.Range("B2:B" & lastRow).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
Sheets("Interface").Range("D19").Value = Sheets("TaskMaster").Range("C" & aCell.Row).Value
Sheets("Interface").Range("D20").Value = Sheets("TaskMaster").Range("D" & aCell.Row).Value
Sheets("Interface").Range("D21").Value = Sheets("TaskMaster").Range("E" & aCell.Row).Value
Sheets("Interface").Range("D22").Value = Sheets("TaskMaster").Range("F" & aCell.Row).Value
Sheets("Interface").Range("D23").Value = Sheets("TaskMaster").Range("G" & aCell.Row).Value
Sheets("Interface").Range("D24").Value = Sheets("TaskMaster").Range("H" & aCell.Row).Value
Sheets("Interface").Range("D25").Value = Sheets("TaskMaster").Range("I" & aCell.Row).Value
Sheets("Interface").Range("D26").Value = Sheets("TaskMaster").Range("J" & aCell.Row).Value
Sheets("Interface").Range("D27").Value = Sheets("TaskMaster").Range("K" & aCell.Row).Value
Sheets("Interface").Range("D28").Value = Sheets("TaskMaster").Range("L" & aCell.Row).Value
Sheets("Interface").Range("D29").Value = Sheets("TaskMaster").Range("M" & aCell.Row).Value
Sheets("Interface").Range("D30").Value = Sheets("TaskMaster").Range("N" & aCell.Row).Value
Sheets("Interface").Range("D31").Value = Sheets("TaskMaster").Range("O" & aCell.Row).Value
Sheets("Interface").Range("D32").Value = Sheets("TaskMaster").Range("P" & aCell.Row).Value
Sheets("Interface").Range("D33").Value = Sheets("TaskMaster").Range("Q" & aCell.Row).Value
Exit Sub
End Sub
Objective: I am attempting to make this code more robust. Part of reasoning is for me to be able to skip blanks. This is a nightmare when trying to adjust cells.
I have tried two different methods to accomplish this:
Method A:
wb.Sheets("Interface").Range("D19:D33").Copy
wb.Sheets("TaskMaster").Range("C" & aCell.Row & ":Q" & aCell.Row).PastSpecial Paste:=xlPasteValues, SkipBlanks:=True
Failure: Runtime Error 438: Object doesn't support this property or method.
Method B:
For j = 3 To 16
If Not IsEmpty(j, aCell.Row) Then
For i = 19 To 33
iWb.oSht.Range(j, aCell.Row).Value = _
iWb.iSht.Range(4, i).Value
Next i
End If
Next j
Exit Sub
Failure: ( I cant get this older version to compile again) I believe the error arose with issues defining the range.
To summarize I am trying to find the fastest method to transfer information from one worksheet to another worksheet using the .find. I am also trying to not copy blank cells while transferring.
I currently believe this method will be the best suited for my application.
Sub TSearch()
Dim dWb As Workbook, Wb As Workbook
Dim oSht As Worksheet, Sht As Worksheet
Dim lastRow As Long, i As Long, j As Long
Dim strSearch As String
Dim aCell As Variant
Dim cell As Variant
'On Error GoTo Err
ThisWorkbook.Sheets("Interface").Range("D19:D33").ClearContents
'Set dWb = Workbooks.Open("H:\Kevin.Boots\Database.xlsx")
Set Wb = ThisWorkbook
Set Sht = Sheets("TaskMaster") ' Reference Worksheet
Set oSht = Sheets("Interface") ' User Interface Worksheet
lastRow = Sht.Range("A" & Rows.Count).End(xlUp).Row 'Obtain Last row of reference Worksheet
strSearch = oSht.Range("F5") 'Obtain User Selected Search Criteria
Set aCell = Sht.Range("B2:B" & lastRow).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
For j = 3 To 16 'Columns from Reference Worksheet to be transfered
If Not IsEmpty(Wb.Sht.Cells(aCell.Row, j)) Then ' Verify If cell has value before transfering
For i = 19 To 33 ' Rows of User Interface where values are to be transfered
Wb.Sht.Cells(aCell.Row, j).Value = _
Wb.oSht.Cells(i, 4).Value
Next i
End If
Next j
Exit Sub
'Err: 'MsgBox " Generic Task not found" & vbCrLf
End Sub
The IEmpty Function is still causing an error 438: Object doesn't support this property method. If I remove the IsEmpty then
'Wb.Sht.Cells(aCell.Row, j).Value = Wb.oSht.Cells(i, 4).Value' gives me the same error.
Your loop won't work due to IsEmpty which expects a single cell or variable to check, but you are giving it two numbers. The below should work, but some things aren't qualified, so you may still run into issues. Also, Range() expects either two ranges to be provided, or a range string. I think you were looking for Cells(), which accepts a row (as a number) as the first parameter and a column (as a number) as the second.
For j = 3 To 16
If Not IsEmpty(cells(aCell.Row, j)) Then
For i = 19 To 33
iWb.oSht.Cells(aCell.Row, j).Value = _
iWb.iSht.Cells(4, i).Value
Next i
End If
Next j
End Sub
It appears the errors were a result of trying to define something that was defined.
Sub TSearch()
Dim dWb As Workbook, Wb As Workbook
Dim oSht As Worksheet, Sht As Worksheet
Dim lastRow As Long, i As Long, j As Long
Dim strSearch As String
Dim aCell As Variant
Dim cell As Variant
'On Error GoTo Err
ThisWorkbook.Sheets("Interface").Range("D19:D33").ClearContents
'Set dWb = Workbooks.Open("H:\Kevin.Boots\Database.xlsx")
Set Wb = ThisWorkbook
Set Sht = Sheets("TaskMaster") ' Reference Worksheet
Set oSht = Sheets("Interface") ' User Interface Worksheet
lastRow = Sht.Range("A" & Rows.Count).End(xlUp).Row 'Obtain Last row of reference Worksheet
strSearch = oSht.Range("F5") 'Obtain User Selected Search Criteria
'Find Row in Reference Worksheet that Matches Search Criteria
Set aCell = Sht.Range("B2:B" & lastRow).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
For j = 3 To 16
If Not IsEmpty(Cells(aCell.Row, j)) Then
i = j + 16
oSht.Cells(i, 4).Value = Cells(aCell.Row, j).Value
End If
Next j
Exit Sub
'Err:
'MsgBox " Generic Task not found" & vbCrLf
End Sub
Thank you to #Jordan and #Kyle for helping solve this issue.
Related
I created a macro that fills the missing Data with specific Data from another sheet , the codes works perfectly in copying pasting data from excel of the client and prepare the data needed to start the work but the only problem here below
Code:
With Worksheets("Feuil2")
' reference "target" sheet (change "Target" to our actual target sheet name)
With .Range("B1:B" & .Cells(.Rows.Count, 1).End(xlUp).Row) 'reference
its column B range from row 1 down to last not empty one
If WorksheetFunction.CountBlank(.Cells) > 0 Then
' if any blank cell in referenced range. this check to avoid error thrown by subsequent
statament
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=index(GDC!" & rng.Offset(, 1).Address(, , xlR1C1) & ",match(RC[-1],GDC!" & rng.Address(, , xlR1C1) & ",0))" 'fill blank cells with a lookup (well, sort of) formula
.Value = .Value 'get rid of formulas and leave values only
Cells.Select
End If
End With
End With
This code works perfectly in matching and filling data but when for e.g find a duplicated value it copy only the first value not the second one
See the image below to better understand the main problem :
As you can see in the image The problem that in column A i may have data repeated twice like this value P20845 which in column F it is repeated one with the name of Ghaith and the other with the name of sirine but as you can see in the column A it is just with the name also of Ghaith and there is no name of sirine
Anyidea or better solution in solving this and getting all the needed DATA? .
Best Regards
POLOS
Or use a dictionary
Option Explicit
Public Sub AddValues()
Application.ScreenUpdating = False
Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet, masterDict As Object, arr() As Variant, i As Long, rng As Range
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Feuil1")
Set wsTarget = wb.Worksheets("Feuil2")
Set masterDict = CreateObject("Scripting.Dictionary")
With wsSource
arr = Intersect(.Columns("A:B"), .UsedRange)
For i = 1 To UBound(arr, 1)
If Not masterDict.exists(arr(i, 1)) Then masterDict.Add arr(i, 1), GetAllMatches(arr(i, 1), arr(i, 2), wsSource)
Next i
End With
With wsTarget
For Each rng In Intersect(.Columns("A"), .UsedRange)
On Error Resume Next
rng.Offset(, 1) = masterDict(rng.Value)
On Error GoTo 0
Next rng
End With
Application.ScreenUpdating = True
End Sub
Public Function GetAllMatches(ByVal findString As String, ByVal dupString As String, ByVal searchRng As Worksheet) As String
Dim foundCell As Range
Dim concatenatedString As String
concatenatedString = vbNullString
With Intersect(searchRng.Columns(1), searchRng.UsedRange)
Set foundCell = .Find(findString)
If foundCell Is Nothing Then Exit Function
If Not foundCell Is Nothing Then concatenatedString = foundCell.Offset(, 1)
Dim currMatch As Long
currMatch = 0
For currMatch = 1 To WorksheetFunction.CountIf(.Cells, findString)
Set foundCell = .Find(What:=findString, After:=foundCell, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not foundCell Is Nothing And InStr(1, dupString, concatenatedString) = 0 Then
concatenatedString = concatenatedString & "/" & foundCell.Offset(, 1)
Else
concatenatedString = foundCell.Offset(, 1)
End If
Next currMatch
End With
GetAllMatches = concatenatedString
End Function
Output in Feuil2
Maybe something like this instead?
Sub Test()
Dim i As Long, myrow As Long, lastrow As Long
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
lastrow = 1
For i = 1 To 7
If Application.WorksheetFunction.CountIf(sht1.Range("A:A"), sht2.Range("F" & i).Value) = 0 Then
If i = 1 Then
lastrow = 1
Else
lastrow = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row + 1
End If
sht1.Range("A" & lastrow).Value = sht2.Range("F" & i).Value
sht1.Range("B" & lastrow).Value = sht2.Range("G" & i).Value
Else
sht1.Range("B" & sht1.Columns("A:A").Find(What:=sht2.Range("F" & i).Value).Row).Value = sht1.Range("B" & sht1.Columns("A:A").Find(What:=sht2.Range("F" & i).Value).Row).Value & "/" & sht2.Range("G" & i).Value
End If
Next i
End Sub
I have searched high and low and have tested many VB scripts but havent found a solution to this. the below is the data I have
Data
Need to have an output like below
result
the VB code I am using
Option Explicit
Public Sub PromptUserForInputDates()
Dim strStart As String, strEnd As String, strPromptMessage As String
'Prompt the user to input the start date
strStart = InputBox("Please enter the start date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Prompt the user to input the end date
strEnd = InputBox("Please enter the end date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Call the next subroutine, which will do produce the output workbook
Call CreateSubsetWorkbook(strStart, strEnd)
End Sub
'This subroutine creates the new workbook based on input from the prompts
Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String)
Dim wbkOutput As Workbook
Dim wksOutput As Worksheet, wks As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long
Dim rngFull As Range, rngResult As Range, rngTarget As Range
'Set references up-front
lngDateCol = 3 '<~ we know dates are in column C
Set wbkOutput = Workbooks.Add
'Loop through each worksheet
For Each wks In ThisWorkbook.Worksheets
With wks
'Create a new worksheet in the output workbook
Set wksOutput = wbkOutput.Sheets.Add
wksOutput.Name = wks.Name
'Create a destination range on the new worksheet that we
'will copy our filtered data to
Set rngTarget = wksOutput.Cells(1, 1)
'Identify the data range on this sheet for the autofilter step
'by finding the last row and the last column
lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set rngFull = .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol))
'Apply a filter to the full range to get only rows that
'are in between the input dates
With rngFull
.AutoFilter Field:=lngDateCol, _
Criteria1:=">=" & StartDate, _
Criteria2:="<=" & EndDate
'Copy only the visible cells and paste to the
'new worksheet in our output workbook
Set rngResult = rngFull.SpecialCells(xlCellTypeVisible)
rngResult.Copy Destination:=rngTarget
End With
'Clear the autofilter safely
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
Next wks
'Let the user know our macro has finished!
MsgBox "Data transferred!"
End Sub
but when data is like below the result doesnt show two rows with different time, any help would be much appreciated please.
Data 3
rgds
thanks for sharing your code. I think it looks a bit more than what you need. Going off your example, if everything is formatted as such, this would be your solution:
Option Explicit
Sub SplitDateTime()
Dim mydate As String, mytime As String, mytime2 As String, i As Long, sht As Worksheet, lastrow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'Change headers
Range("H1:H" & lastrow).Value = Range("G1:G" & lastrow).Value
Range("G1:G" & lastrow).Value = Range("F1:F" & lastrow).Value
Range("D1").Value = "Date"
Range("E1").Value = "C/In"
Range("F1").Value = "C/Out"
'Move values around
For i = 2 To lastrow Step 2
mydate = DateValue(Range("D" & i).Value)
mytime = TimeValue(Range("D" & i).Value)
mytime2 = TimeValue(Range("D" & i + 1).Value)
Range("D" & i).Value = mydate
Range("E" & i).Value = mytime
Range("F" & i).Value = mytime2
Next i
'Delete excess rows
For i = lastrow To 2 Step -2
Range("A" & i).EntireRow.Delete
Next i
'Regrab lastrow value
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'Change date format
Range("D2:D" & lastrow).NumberFormat = "m/d/yyyy"
End Sub
I have maintained two Excel reports EPC1.xlsx and Control Power Transformers.xlsm respectively.
I want to trigger an button click from Control Power Transformers.xlsm report where it will search for "CTPT" term in "A" column from EPC1.xlsx, once it finds the term it need to copy Column B and Column c till the row ends (in EPC1.xlsx) and paste it in Control Power Transformers.xlsm workbook
I am successful in retrieving the cell address of "CTPT" term but how to select the data from adjacent column B and C?
And this is what I have tried
Private Sub CommandButton23_Click()
Dim rngX As Range
Dim num As String
Windows("EPC 1.xlsx").Activate
Set rngX = Worksheets("Sheet1").Range("A1:A10000").Find("CTPT", Lookat:=xlPart)
num = rngX.Address ' Here we will the get the cell address of CTPT ($A$14)
Range(rngX, Range("C" & rngX.Row).End(xlDown)).Copy
Windows("Control Power Transformers.xlsm").Activate
Sheets("Sheet2").Select
ActiveSheet.Range("E2").PasteSpecial (xlPasteValues)
End Sub
Paste the below in sample workbook. The below code will help to select both files using file dialog. It will search for word "CTPT". if so it will copy the column values from CTPT sheet to control file.
Sub DetailsFilePath()
Dim File1 As String
Dim File2 As String
Dim findtext As String
Dim copyvalues As Long
Dim c As Variant
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
MsgBox "Open the CTPT file"
Application.FileDialog(msoFileDialogFilePicker).Show
'On Error Resume Next
' open the file
File1 = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
MsgBox "Open the Control Power Transformers file"
Application.FileDialog(msoFileDialogFilePicker).Show
File2 = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
Set wb1 = Workbooks.Open(Filename:=File1)
Set ws1 = wb1.Worksheets("sheet1")
Set wb2 = Workbooks.Open(Filename:=File2)
Set ws2 = wb2.Worksheets("sheet1")
findtext = "CTPT"
With ws1.Columns(1)
Set c = .Find(findtext, LookIn:=xlValues)
If Not c Is Nothing Then
copyvalues = c.Column
ws2.Columns(2).Value = ws1.Columns(2).Value
ws2.Columns(3).Value = ws1.Columns(3).Value
End If
End With
wb1.Close savechanges:=True
wb2.Close savechanges:=True
End Sub
You need to use FindNext to find other results, and the Offset will help you select what you want from the address of your results :
Sub test_Karthik()
Dim WbEPC As Workbook, _
WbCPT As Workbook, _
WsEPC As Worksheet, _
WsCPT As Worksheet, _
FirstAddress As String, _
WriteRow As Long, _
cF As Range, _
num As String
Set WbEPC = Workbooks("EPC 1.xlsx")
Set WbCPT = Workbooks("Control Power Transformers.xlsm")
Set WsEPC = WbEPC.Sheets("Sheet1")
Set WsCPT = WbCPT.Sheets("Sheet2")
With WsEPC
.Activate
With .Range("A1:A10000")
'First, define properly the Find method
Set cF = .Find(What:="CTPT", _
After:=ActiveCell, _
LookIn:=xlValues, _
Lookat:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
'If there is a result, keep looking with FindNext method
If Not cF Is Nothing Then
FirstAddress = cF.Address
Do
num = cF.Address ' Here we will the get the cell address of CTPT ($A$14)
WsEPC.Range(cF.Offset(0, 1), cF.Offset(0, 2).End(xlDown)).Copy
WriteRow = WsCPT.Range("E" & WsCPT.Rows.count).End(xlUp).Row + 1
WsCPT.Range("E" & WriteRow).PasteSpecial (xlPasteValues)
Set cF = .FindNext(cF)
'Look until you find again the first result
Loop While Not cF Is Nothing And cF.Address <> FirstAddress
End If
End With
End With
End Sub
I want a to make some code that searches all the worksheets for the string "Question" then take "5" lines below it. Then take those 5 lines and put them in the worksheet "Template" from lines "B2".
Here is my current code:
Dim SearchString As String
Dim SearchRange As Range, cl As Range
Dim FirstFound As String
Dim sh As Worksheet
' Set Search value
SearchString = "Question"
Application.FindFormat.Clear
' loop through all sheets
For Each sh In ActiveWorkbook.Worksheets
' Find first instance on sheet
Set cl = sh.Cells.Find(What:=SearchString, _
After:=sh.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not cl Is Nothing Then
' if found, remember location
FirstFound = cl.Address
' format found cell
Do
cl.Font.Bold = True
cl.Interior.ColorIndex = 3
' find next instance
Set cl = sh.Cells.FindNext(After:=cl)
Loop Until FirstFound = cl.Address
End If
Next
All this code does is find the string. How do I take the data below the string and copy them to "Template" worksheet?
You will want to invest in the .Offset Method:
Dim RangeToCopy As Range, DestRow As Long
Set RangeToCopy = sh.Range(cl.Offset(1, 0), cl.Offset(5, 0))
RangeToCopy.Copy
DestRow = Sheets("Template").Range("B" & Rows.Count).End(xlUp).Row + 1
Sheets("Template").Range("B" & DestRow).PasteSpecial xlPasteValues
I have a block of code that takes way too long to process for some files. Smaller files (fewer lines of data) work fine, but once I get to about 150-300, it starts to get slow, (sometimes I think the whole process actually just hangs) and I have to run this sometimes on files with up to 6,000.
I want to plug in a VLookup() function in the .FormulaR1C1 for a number of cells. I know that I can set the whole range at once using .Range("J2:J" & MaxRow). However, I am looping through a block of cells to check the value of those cells. IF they are empty, THEN I want to apply the formula. If those cells already have values, then I don't want to change them, so I don't think the whole range option will work for me (at least I was unable to get it right).
Private Sub PullMIAFinalizedData(NewMIARep As Worksheet, MaxRow As Long, wkbFinalized As Workbook)
Dim wksFinalized As Worksheet
Dim lCount As Long
Dim sVLookupJBlock As String
Dim sVLookupKBlock As String
Application.Calculation = xlCalculationManual
sVLookupJBlock = "=IF(ISERROR(" & _
"VLOOKUP(RC1,'[" & wkbFinalized.Name & "]" & wksFinalized.Name & "'!C1:C13,13,FALSE))," & _
Chr(34) & Chr(34) & _
",VLOOKUP(RC1,'[" & wkbFinalized.Name & "]" & wksFinalized.Name & "'!C1:C13,13,FALSE))"
sVLookupKBlock = "=IF(ISERROR(" & _
"VLOOKUP(RC1,'[" & wkbFinalized.Name & "]" & wksFinalized.Name & "'!C1:C3,3,FALSE))," & _
Chr(34) & Chr(34) & _
",VLOOKUP(RC1,'[" & wkbFinalized.Name & "]" & wksFinalized.Name & "'!C1:C3,3,FALSE))"
For Each wksFinalized In wkbFinalized.Sheets
ShowAllRecords wksFinalized 'Custom Function to unhide/unfilter all data
With NewMIARep
For lCount = 2 To MaxRow
If .Range("J" & lCount).value = "" And .Range("K" & lCount).value = "" Then
.Range("J" & lCount).FormulaR1C1 = sVLookupJBlock
.Range("K" & lCount).FormulaR1C1 = sVLookupKBlock
Application.Calculate
With .Range("J" & lCount & ":K" & lCount)
.value = .value
End With
End If
Next lCount
.Range("J2:J" & MaxRow).NumberFormat = "mm/dd/yyyy"
End With
Next wksFinalized
Application.Calculation = xlCalculationAutomatic
End Sub
Am I just stuck with this?
Thanks very much to assylias and Siddharth Rout for helping out with this; both provided very useful information, which led to this result:
Private Sub PullMIAFinalizedData(NewMIARep As Worksheet, MaxRow As Long, wkbFinalized As Workbook)
Dim wksFinalized As Worksheet
Dim lCount As Long
Dim lFinMaxRow As Long
Dim DataRange As Variant 'per assylias, using a variant array to run through cells
Dim FoundRange As Range
Application.Calculation = xlCalculationManual
With NewMIARep
DataRange = .Range("J2:K" & MaxRow)
For Each wksFinalized In wkbFinalized.Sheets
ShowAllRecords wksFinalized
lFinMaxRow = GetMaxRow(wksFinalized)
If lFinMaxRow > 1 Then
For lCount = 1 To MaxRow - 1
If Len(DataRange(lCount, 1)) = 0 And Len(DataRange(lCount, 2)) = 0 Then
'per Siddharth Rout, using Find instead of VLookup
Set FoundRange = wksFinalized.Range("A2:A" & lFinMaxRow).Find(What:=.Range("A" & lCount).value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not FoundRange Is Nothing Then
DataRange(lCount, 1) = FoundRange.Offset(ColumnOffset:=12).value
DataRange(lCount, 2) = FoundRange.Offset(ColumnOffset:=2).value
Set FoundRange = Nothing
End If
End If
Next lCount
End If
Next wksFinalized
.Range("J2:K" & MaxRow).value = DataRange
.Range("J2:J" & MaxRow).NumberFormat = "mm/dd/yyyy"
End With
Application.Calculation = xlCalculationAutomatic
End Sub
You don't want to iterate on cells from VBA: it is EXTREMELY slow. Instead, you put the data you need into an array, work on the array and put the data back to the sheet. In your case, something like the code below (not tested):
Dim data as Variant
Dim result as Variant
Dim i as Long
data = ActiveSheet.UsedRange
ReDim result(1 To UBound(data,1), 1 To UBound(data,2)) As Variant
For i = LBound(data,1) to UBound(data,1)
'do something here, for example
If data(i,1) = "" Then
result(i,1) = "=VLOOKUP($A1,$A:$G," & i & ",FALSE)"
Else
result(i,1) = data(i,1)
End If
Next i
ActiveSheet.Cells(1,1).Resize(Ubound(result, 1), UBound(result,2)) = result