I am looping through a set of data with VBA Excel. I am trying to find a certain string using a combination the Range.Find and the Range.FindNext methods. I having a hard time figuring out where to place these statements because I need them to be in the scope of each other but at the same time I don't want the first Find statement to keep executing every time, hence only looping over the first match.
Sub AssignGroups()
Dim membership As Worksheet
Dim wb As Workbook
Dim groups As Worksheet
Dim nameRow As Long
Dim fullNameString As String
Dim nameRange As Range
Dim groupRange As Range
Dim nameRange2 As Range
Dim nameIndex As Long
Dim userNameString As String
Dim barIndex As Long
Set wb = ActiveWorkbook
Set membership = Sheets("User Group Membership")
Set groups = Sheets("User Assigned to Groups")
Set nameRange = membership.Range("A:A").Find("user -name", Lookat:=xlPart)
If Not nameRange Is Nothing Then
firstAddress = nameRange.Address
Set nameRange = membership.Range("A:A").Find("user -name", Lookat:=xlPart)
Do
membership.Activate
nameRow = nameRange.Row
MsgBox (nameRow)
fullNameString = membership.Cells(nameRow, "A").Value
MsgBox (fullNameString)
nameIndex = InStr(fullNameString, "user -name")
barIndex = InStr(fullNameString, "|")
MsgBox (nameIndex)
MsgBox (barIndex)
userNameString = Mid(fullNameString, nameIndex + 12, ((barIndex - 4) - (nameIndex + 12)))
groups.Activate
Set nameRange2 = groups.Range("A:CH").Find(userNameString)
nameColumn = nameRange2.Column
membership.Activate
membership.Cells(nameRow, "A").Activate
Do
ActiveCell.Offset(1).Activate
If Not IsEmpty(ActiveCell.Value) Then
cellValue = ActiveCell.Value
groups.Activate
Set groupRange = groups.Range("A:CH").Find(cellValue, , , Lookat:=xlWhole)
groupRow = groupRange.Row
groups.Cells(groupRow, nameColumn).Activate
ActiveCell.Value = "X"
membership.Activate
End If
Loop Until IsEmpty(ActiveCell.Value)
Set nameRange = membership.Range("A:A").FindNext(ActiveCell)
Loop While Not nameRange Is Nothing And nameRange.Address <> firstAddress
End If
End Sub
How could I place these statements so that it would loop over all the matches, one after another?
Related
all.
I'm running this code:
Sub ISN_Flyer_Performance()
Dim FlyerSh As Worksheet
Dim QlikSh As Worksheet
Dim SKURng As Range
Dim QlikSKURng As Range
Dim SKU As Range
Dim qlr As Long
Dim QlikSKU As Range
Dim TotalSales As Double
Dim FirstQlikSku As Range
Set FlyerSh = ActiveSheet
i = 2
lr = FlyerSh.Range("A" & Rows.Count).End(xlUp).Row
Set QlikSh = Application.InputBox("Click any cell on the Qlikview Sheet you want to lookup against", "Find Qlikview Sheet", Type:=8).Worksheet
qlr = QlikSh.Range("A" & Rows.Count).End(xlUp).Row
Set QlikSKURng = Range(Cells(2, QlikSh.Rows(1).Find(What:="Item Number", LookAt:=xlWhole).Column), Cells(qlr, QlikSh.Rows(1).Find(What:="Item Number", LookAt:=xlWhole).Column))
Set SKURng = Range(FlyerSh.Cells(i, 1), FlyerSh.Cells(lr, 1))
Set SKU = FlyerSh.Cells(i, 1)
For Each SKU In SKURng
Set QlikSKU = QlikSKURng.Find(What:=SKU.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If QlikSKU Is Nothing Then
SKU.Offset(0, 2).Value = 0
GoTo NextSku
Else
TotalSales = QlikSKU.Offset(0, 5).Value
Set FirstQlikSku = QlikSKU
Do
Set QlikSKU = QlikSKURng.FindNext(QlikSKU)
If QlikSKU.Address = FirstQlikSku.Address Then Exit Do
TotalSales = TotalSales + QlikSKU.Offset(0, 5).Value
Loop
SKU.Offset(0, 2) = TotalSales
End If
NextSku:
Next SKU
End Sub
It's essentially like an XLookup, where it gets the thing to seach on one workbook, then finds it on a second, sends the value back to the first one, and moves on to the next item. I'd use an XLookup, but unfortunately, my sheet will always have duplicates, and I need to count both.
So I'm using this findnext loop to loop through a range (QlikSKURange) which has about 16k rows. The findNext is reasonably quick, like less than a second, EXCEPT the last instance when it goes back to the beginning and finds the first instance again. That instance can take over ten seconds.
Any idea why that might be?
Let me know if you need more info about the code.
I tried to just "Find" after the current iteration, instead of find next, and it has the same slow down.
VBA Lookup Using the Find Method
This is just the basic idea. There are many flaws e.g. if you cancel the input box, if you select a 'wrong' worksheet (e.g. column header not found), if there are error values, blank cells, etc.
Option Explicit
Sub ISN_Flyer_Performance()
' Flyer
Dim fws As Worksheet: Set fws = ActiveSheet ' improve!
Dim fLR As Long: fLR = fws.Range("A" & fws.Rows.Count).End(xlUp).Row
Dim frg As Range
Set frg = fws.Range(fws.Cells(2, "A"), fws.Cells(fLR, "A"))
'Debug.Print fws.Name, fLR, frg.Address
' Qlikview
Dim qws As Worksheet: Set qws = Application.InputBox( _
"Click any cell on the Qlikview Sheet you want to lookup against", _
"Find Qlikview Sheet", Type:=8).Worksheet
Dim qLR As Long: qLR = qws.Range("A" & qws.Rows.Count).End(xlUp).Row
Dim qC As Long
With qws.Rows(1) ' assuming that "Item Number" is surely in the first row
qC = .Find("Item Number", .Cells(.Cells.Count), _
xlFormulas, xlWhole).Column
End With
Dim qrg As Range
Set qrg = qws.Range(qws.Cells(2, qC), qws.Cells(qLR, qC))
'Debug.Print qws.Name, qLR, qC, frg.Address
Application.ScreenUpdating = False
Dim fCell As Range
Dim qCell As Range
Dim qFirstAddress As String
Dim TotalSales As Double
' Loop.
For Each fCell In frg.Cells
Set qCell = qrg.Find(fCell.Value, qrg.Cells(qrg.Cells.Count), _
xlFormulas, xlWhole)
If qCell Is Nothing Then
fCell.Offset(0, 2).Value = 0
Else
qFirstAddress = qCell.Address
Do
TotalSales = TotalSales + qCell.Offset(0, 5).Value
Set qCell = qrg.FindNext(qCell)
Loop Until qCell.Address = qFirstAddress
fCell.Offset(0, 2).Value = TotalSales
TotalSales = 0
End If
Next fCell
Application.ScreenUpdating = True
MsgBox "Lookup done.", vbInformation
End Sub
After doing more digging, someone suggested that the issue was that one of my sheets was a table. It had filters on the header row. I removed those (and conditional formatting on a row to find duplicates, and my code ran in a matter of seconds. After isolating those two, turns out the conditional formatting was the culprit.
I have a workbook with several worksheets. The main worksheet is the Data worksheet.
The search criteria are in the Data worksheet B2,C2 and D2.The other sheets are cross tabs in which the prices are located. The prices I am looking for should be transferred in sheet Data column G2. I stuck with following code.
Dim wks As Worksheet
Dim wksData As Worksheet: Set wksData = Sheets("Data")
Dim lngrow As Long
Dim lngrow2 As Long
Dim lngSpalte As Long
For lngrow = 2 To wksData.Cells(Rows.Count, 2).End(xlUp).Row
Select Case wksData.Cells(lngrow, 2).Value
Case "Standard"
Set wks = Sheets("Standard")
Case "Express Plus"
Set wks = Sheets("Express Plus")
Case "Express Saver"
Set wks = Sheets("Express Saver")
End Select
For lngrow2 = 2 To wks.Cells(Rows.Count, 2).End(xlUp).Row
If Trim(wks.Cells(lngrow2, 2).Value) = Trim(wksData.Cells(lngrow, 3).Value) Then
For lngSpalte = 2 To 10
If Trim(wks.Cells(lngSpalte, 3).Value) = Trim(wksData.Cells(lngrow, 4)) Then
wksData.Cells(lngrow, 7).Value = wks.Cells(lngrow2, lngSpalte).Value
Exit For
End If
Next
End If
Next
Next
Is anyone able to help? Thank you!
EDIT - based on your sample workbook...
Sub Tester()
Dim wksData As Worksheet, wks As Worksheet
Dim lngrow As Long
Dim delType, delZone, delWeight, mCol, rv
Dim rngWts As Range, arrWts, rngZones As Range, i As Long, w As Double
Set wksData = Sheets("Data")
For lngrow = 2 To wksData.Cells(Rows.Count, 2).End(xlUp).Row
delType = Trim(wksData.Cells(lngrow, "B").Value) 'use some descriptive variables!
delZone = wksData.Cells(lngrow, "C").Value
delWeight = CDbl(Trim(wksData.Cells(lngrow, "D").Value))
rv = "" 'clear result value
Select Case delType
Case "Standard", "Express Plus", "Express Saver"
Set wks = Sheets(delType) 'simpler...
Set rngWts = wks.Range("A3:A" & wks.Cells(Rows.Count, "A").End(xlUp).Row)
arrWts = rngWts.Value
'loop over the weights data
For i = 1 To UBound(arrWts, 1) - 1
If delWeight >= arrWts(i, 1) And delWeight < arrWts(i + 1, 1) Then
Set rngZones = wks.Range("B2", wks.Cells(2, Columns.Count).End(xlToLeft)) 'zones range
mCol = Application.Match(delZone, rngZones, 0) 'find the matching Zone
If Not IsError(mCol) Then 'got zone match?
rv = rngWts.Cells(i).Offset(0, mCol).Value
Else
rv = "Zone?"
End If
Exit For 'stop checking weights column
End If
Next i
If Len(rv) = 0 Then rv = "No weight match"
Case Else
rv = "Delivery type?"
End Select
wksData.Cells(lngrow, "G").Value = rv 'populate the result
Next
End Sub
I have been working on this program that...
Finds a five-digit code in a workbook
Looks in a second workbook to find a matching code
Copies a set of corresponding data from the first workbook onto the second.
It works for the most part, but when there is a value that is present on the first book but not the second it fails. If I let it run the values get messed up, but the program does complete. I need to find a way to recognize an error, which would be foundItem = 0, and then restart the loop from that point so nothing gets copied. I appreciate the help.
Sub findExample()
On Error Resume Next
Dim foundItem As Range
Dim codeValue As String
Dim strAddress As String
Dim endOfWorksheet As Boolean
Dim x As Long
x = 1
Do While endOfWorksheet = False
x = x + 1
Sheets("Medex Center Master List").Select
Dim NRange As String
NRange = "N" + CStr(x)
codeValue = Range(NRange, NRange).Value
Sheets("6035P_ATRSDeviceListII").Select
Set foundItem = Range("M1:M300").Find(codeValue)
Dim col
Dim rowa
col = Split(foundItem.Address, "$")(1)
rowa = Split(foundItem.Address, "$")(2)
strAdress = col + rowa
Dim FRange As String
FRange = "A" + CStr(x) + ":" + "M" + CStr(x)
Sheets("Medex Center Master List").Range(FRange).Copy Sheets("6035P_ATRSDeviceListII").Range(strAdress).Offset(0, 1)
If x = 265 Then
endOfWorksheet = True
End If
Loop
MsgBox "program completed"
End Sub
Thanks Again,
Samuel
As mentioned in comments but with more detail:
Remove the On Error Resume Next. It is just hiding any errors that are occurring.
Your code could be simplified and improved in the following manner:
Use a regular For...Next loop.
Avoid using Select.
Specify more parameters of Range.Find, specifically LookIn and LookAt.
Test if the Find succeeded using If Not ... Is Nothing Then.
Sub FindExample()
Dim i As Long
For i = 1 to 265
Dim masterWs As Worksheet
Set masterWs = ThisWorkbook.Worksheets("Medex Center Master List")
Dim codeValue As String
codeValue = masterWs.Range("N" & i).Value
Dim deviceListWs As Worksheet
Set deviceListWs = ThisWorkbook.Worksheets("6035P_ATRSDeviceListII")
Dim foundItem As Range
Set foundItem = deviceListWs.Range("M1:M300").Find( _
What:=codeValue, LookIn:=xlValues, LookAt:=xlWhole)
If Not foundItem Is Nothing Then
masterWs.Range("A" & i & ":M" & i).Copy _
Destination:=foundItem.Offset(0,1)
End If
Next
End Sub
I need to contactinate data of two columns from two different worksheets using vba macro.
Ex- in an excel sheet there are two tabs/worksheets sheet1 and sheet2. sheet1 is having column firstname & middlename, sheet2 is having column last name. I want to concat all first,middle & last name .
i am able to concat column which are present in same worksheet but not the column from different worksheets. Kindly suggest.
Thanks.
As you wanted a VBA solution, I've put something together for you. It checks if the number of rows in columns A in the two sheets are the same, loads the data from columns A/B in the first sheet and column A in the second sheet into an array, and then loops these arrays, concatenating then with spaces between using Trim to cater for missing values and writing this to the column B of the second sheet:
Sub sConcatenate()
Dim wsFName As Worksheet
Dim wsLName As Worksheet
Dim wsOutput As Worksheet
Dim lngLastRow As Long
Dim lngLoop1 As Long
Dim aFName() As Variant
Dim aMName() As Variant
Dim aLName() As Variant
Set wsFName = ThisWorkbook.Worksheets("FName")
Set wsLName = ThisWorkbook.Worksheets("LName")
Set wsOutput = ThisWorkbook.Worksheets("LName")
lngLastRow = wsFName.Cells(wsFName.Rows.Count, "A").End(xlUp).Row
If lngLastRow = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row Then
aFName = wsFName.Range("A1:A" & lngLastRow).Value
aMName = wsFName.Range("B1:B" & lngLastRow).Value
aLName = wsLName.Range("A1:A" & lngLastRow).Value
For lngLoop1 = LBound(aFName, 1) To UBound(aFName, 1)
wsOutput.Cells(lngLoop1, 2) = Trim(Trim(aFName(lngLoop1, 1) & " " & aMName(lngLoop1, 1)) & " " & aLName(lngLoop1, 1))
Next lngLoop1
End If
Set wsFName = Nothing
Set wsLName = Nothing
Set wsOutput = Nothing
End Sub
Regards,
Why don't you just use the CONCATENATE function? Open both workbooks and in the destination cell write the CONCATENATE function with the directions.
=CONCATENATE(Cell from Workbook 1," ",Cell from Workbook 2)
You didn't mention the details of your use case. But if you want something programatic, the code below shows how you can reference different workbooks and worksheets. You can a for loop and modify it for your use case.
Sub conc()
Dim destination_Wb as Workbook, wb1 As Workbook, wb2 As Workbook
Dim destination_Ws as Worksheet, ws1 As Worksheet, ws2 As Worksheet
Set destination_Wb = Workbooks(“Destination Workbook.xlsm”)
...
...
Set destination_Ws = destination_Wb.Sheets("Sheet1")
...
...
destination_Ws.Cells(1, 1).Value = ws1.Cells(1, 1).Value + " " + ws2.Cells(1, 1).Value
End sub
Concatenate Columns
Adjust the values in the constants section.
The Code
Option Explicit
Sub ConcatNames()
Const Source As String = "Sheet1"
Const Target As String = "Sheet2"
Const NameColumn As Long = 1
Const MiddleNameColumn As Long = 2
Const LastNameColumn As Long = 1
Const FullNameColumn As Long = 2
Const FirstRow As Long = 2
Dim rng As Range
Dim vName, vMiddle, vLast, vFull
Dim RowsCount As Long, i As Long
Dim CurrString As String
With ThisWorkbook.Worksheets(Source)
Set rng = .Columns(NameColumn).Find(What:="*", _
LookIn:=xlFormulas, SearchDirection:=xlPrevious)
Set rng = .Range(.Cells(FirstRow, NameColumn), rng)
vName = rng
RowsCount = rng.Rows.Count
Set rng = .Cells(FirstRow, MiddleNameColumn).Resize(RowsCount)
vMiddle = rng
End With
With ThisWorkbook.Worksheets(Target)
Set rng = .Cells(FirstRow, LastNameColumn).Resize(RowsCount)
vLast = rng
End With
ReDim vFull(1 To RowsCount, 1 To 1)
For i = 1 To RowsCount
GoSub BuildString
Next i
With ThisWorkbook.Worksheets(Target)
Set rng = .Cells(FirstRow, FullNameColumn).Resize(RowsCount)
rng = vFull
End With
Exit Sub
BuildString:
If vName(i, 1) = "" Then Return
CurrString = vName(i, 1)
If vMiddle(i, 1) <> "" Then CurrString = CurrString & " " & vMiddle(i, 1)
If vLast(i, 1) <> "" Then CurrString = CurrString & " " & vLast(i, 1)
vFull(i, 1) = WorksheetFunction.Trim(CurrString)
Return
End Sub
I'm working with two workbooks. In the first I search for the value in the cell to the right of "Charge Number". Take that value and search the second workbooks pivot table for the matching row, copy it and go back to first work book and paste the data. This works great once. But I'm unable to get a loop to look for the next instance of "Charge Number" and repeat the process. The loop I have in the code isn't right because it finds the first value fine but then searches every next row for the same Charge Number.
Sub FindChargeNo()
Dim Loc As Range
Dim ChgNum As String
Dim SrchRng2 As String
Dim pvt As PivotTable
Dim wb As Workbook, ws As Worksheet
Dim FstWB As Workbook
Dim SecWB As Workbook
Dim rng As Range
Set FstWB = Workbooks("First.xlsm")
Set SecWB = Workbooks("Second_test.xlsx")
Set ws1 = FstWB.Worksheets("New Development")
Set ws = SecWB.Worksheets("Aug 18 Report")
Set pvt = ws.PivotTables(1)
lastRow = FstWB.Worksheets("New Development").Range("J" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
Set Loc = ws1.Cells.Find(What:="Charge Number")
If Not Loc Is Nothing Then
ChgNum = Loc.Offset(0, 1).Value
Debug.Print ChgNum
Debug.Print SrchRng
With pvt.PivotFields("Project WBS").PivotItems(ChgNum).LabelRange
Set rng = ws.Range(.Resize(.Rows.Count, pvt.TableRange1.Columns.Count).Address)
ws.Range(rng.Address).Copy
End With
SrchRng2 = Loc.Offset(0, 5).Address
FstWB.Worksheets("New Development").Range(SrchRng2).PasteSpecial
Set Loc = ws1.Cells.FindNext(Loc)
Loop While Loc.Address <> firstAddress
End If
Next
End Sub