Match IDs in a column (comma delimited string of IDs per cell) to another sheet, pull the relevant values over & apply hyperlink - excel

Need some help with an Excel macro-- I'm currently struggling to write a macro that combines all three processes. I have two sheets: Sheet 1 contains a column with multiple IDs in each cell delimited by commas (can go up to like 30 IDs in one cell), Sheet 2 contains data for each of the IDs.
Here's the sequence that I'm trying to achieve:
De-concatenate IDs in Sheet 1 into separate cells
Match each of the de-concatenated IDs to its row in Sheet 2, copy over and add values from column 6 and 7 to Sheet 1's respective cell.
Apply a hyperlink to the final cell.
For example, here's what a row in Sheet 1 & 2 currently look like:
Sheet 1
ID
123456, 789123
Sheet 2
ID
Status
Class
123456
In Progress
A
789123
Done
B
And here's what I'd like the output to look for Sheet 1 when the macro runs:
ID
123456, 789123
123456, In Progress, A
789123, Done, B
My code is super off, but here's what I have:
Set wb = ThisWorkbook
Dim sel As Range
Set sel = Selection
Dim arr() As String
Dim cell As Range
Dim i As Long
Set wsCheck = wb.Sheets("2")
'Column N (IDs)
wb.Sheets("1").Columns("N:N").Select
For Each cell In sel
arr = Split(cell, ",")
For i = 0 To UBound(arr)
m = Application.Match("*" & arr(i) & "*", wsCheck.Columns(1), 0)
If Not IsError(m) Then
cell.Offset(0, i + 1).Value = wsCheck.Cells(m, 6).Value & wsCheck.Cells(m, 7).Value
cell.Parent.Hyperlinks.Add Anchor:=cell.Offset(0, i + 1), Address:="URL" & arr(i), TextToDisplay:=arr(i)
End If
Next i
Next cell

Try this:
Sub test()
Dim wb As Workbook, arr, ws As Worksheet, wsCheck As Worksheet
Dim cell As Range
Dim i As Long, v, m
Set wb = ThisWorkbook
Set ws = wb.Sheets("1")
Set wsCheck = wb.Sheets("2")
If Not TypeOf Selection Is Range Then Exit Sub 'make sure a range is selected
If Selection.Worksheet.Name <> ws.Name Then Exit Sub '...on the correct sheet
For Each cell In Selection.EntireRow.Columns("N").Cells
arr = Split(cell.Value, ",")
For i = 0 To UBound(arr)
v = CLng(Trim(arr(i))) 'remove spaces and convert to number
m = Application.Match(v, wsCheck.Columns(1), 0)
If Not IsError(m) Then
With cell.Offset(0, i + 1)
.Value = Join(Array(v, wsCheck.Cells(m, 6).Value, _
wsCheck.Cells(m, 7).Value), ",")
.Parent.Hyperlinks.Add Anchor:=.Cells(1), _
Address:="", _
SubAddress:=wsCheck.Cells(m, 1).Address(0, 0, xlA1, True), _
TextToDisplay:=.Value
End With
End If
Next i
Next cell
End Sub

Related

Loop through column matching data in workbook and return a value

I have been trying to adapt the following code to
Loop through column A of Sheet 1 and for each value in column A search the whole workbook for it's matching value (which will be found in another sheet also in column A). When a match is found, return the value found in the same row but from column F.
Sub Return_Results_Entire_Workbook()
searchValueSheet = "Sheet2"
searchValue = Sheets(searchValueSheet).Range("A1").Value
returnValueOffset = 5
outputValueSheet = "Sheet2"
outputValueCol = 2
outputValueRow = 1
Sheets(outputValueSheet).Range(Cells(outputValueRow, outputValueCol), Cells(Rows.Count, outputValueCol)).Clear
wsCount = ActiveWorkbook.Worksheets.Count
For I = 1 To wsCount
If I <> Sheets(searchValueSheet).Index And I <> Sheets(outputValueSheet).Index Then
'Perform the search, which is a two-step process below
Set Rng = Worksheets(I).Cells.Find(What:=searchValue, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
rangeLoopAddress = Rng.Address
Do
Set Rng = Sheets(I).Cells.FindNext(Rng)
Sheets(outputValueSheet).Cells(Cells(Rows.Count, outputValueCol).End(xlUp).Row + 1, outputValueCol).Value = Sheets(I).Range(Rng.Address).Offset(0, returnValueOffset).Value
Loop While Not Rng Is Nothing And Rng.Address <> rangeLoopAddress
End If
End If
Next I
End Sub
The code above works but only for the first row of data on Sheet1.
Any help would be greatly appreciated!
You can create an array of arrays where each index of main array would be the dataset A:F from each worksheet:
Sub test()
Dim WK As Worksheet
Dim LR As Long
Dim i As Long
Dim j As Long
Dim MasterArray() As Variant
Dim WkArray As Variant
'create master aray
ReDim MasterArray(1 To ThisWorkbook.Worksheets.Count - 1) 'As many indexes as worksheets -1 (because master sheet does not count)
i = 1
For Each WK In ThisWorkbook.Worksheets
If WK.Name <> "Hoja1" Then 'exclude master sheet witch search values
LR = WK.Range("A" & WK.Rows.Count).End(xlUp).Row 'last non-blank row
WkArray = WK.Range("A1:F" & LR).Value 'take all values in A:F to singlearray
MasterArray(i) = WkArray
Erase WkArray
i = i + 1
End If
Next WK
'now in Master array you have in each index all the values
' as example, if you call MasterArray(1)(1, 1) it will return cell value A1 from first worksheet
Set WK = ThisWorkbook.Worksheets("Hoja1") 'master sheet witch search values
With Application.WorksheetFunction
LR = WK.Range("A" & WK.Rows.Count).End(xlUp).Row 'last non-blank row
For i = 1 To LR Step 1 'for each row in master sheet until last non blank
For j = 1 To UBound(MasterArray) Step 1 'for each dataset in masterarray
WkArray = Application.Transpose(Application.Index(MasterArray(j), , 1)) 'first column of dataset (A column)
If IsError(Application.Match(WK.Range("A" & i).Value, WkArray, 0)) = False Then 'if value exists get F
WK.Range("B" & i).Value = .VLookup(WK.Range("A" & i).Value, MasterArray(j), 6, 0)
Erase WkArray
Exit For
End If
Erase WkArray
Next j
Next i
End With
Erase MasterArray
Set WK = Nothing
End Sub
The code first creates the main array named MasterArray. Then it loops trough each value on column A from Master Sheet (named Hoja1 in my example) and checks if the value exists in each subarray. If it does then returns columns F from dataset and keep looping.
After executing code I get this output:
Notice value 2 returns nothing because it does not exist in any of the other sheets.

Speed up and simplify

I cobbled together something that does work for me as is, but it runs very slowly and I'm sure the code can be simplified.
Sub CopyPasteValues()
Dim strSht1, strSht2 As String
Dim c, rng As Range
strSht1 = "Edit"
strSht2 = "LOB"
With ThisWorkbook.Sheets(strSht1)
Set rng = Range("J2:AJ37")
For Each c In rng
If Not c.Value = 0 Then
Cells(c.Row, 2).Copy
ThisWorkbook.Sheets(strSht2).Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Range(Cells(c.Row, 4), Cells(c.Row, 5)).Copy
ThisWorkbook.Sheets(strSht2).Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
c.Copy
ThisWorkbook.Sheets(strSht2).Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Cells(c.Column).Copy
ThisWorkbook.Sheets(strSht2).Range("G" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
Next c
End With
End Sub
I appreciate any assistance.
As BigBen Mentioned, array method.
Super Fast.
Sub Move_Values_Array_Method()
Dim SourceSheet As Worksheet 'Source Worksheet
Dim DestinationSheet As Worksheet 'Destination Worksheet
Dim RG As Range 'Source Range
Dim InArr() 'Data In Array
Dim OutArr() 'Data Out Array
Dim X As Long 'Array X Position for purposes of iterating through array.
Dim Y As Long 'Array Y Position for purposes of iterating through array.
Dim Cnt As Long 'Found Value Count
Set SourceSheet = ThisWorkbook.Worksheets("Edit") 'Set Source Worksheet
Set DestinationSheet = ThisWorkbook.Worksheets("LOB") 'Set Dest Worksheet
Set RG = SourceSheet.Range("J2:AJ37") 'Set Source Range
ReDim OutArr(1 To RG.Cells.Count) 'Count Cells in Range, resize output array to be at least that big.
InArr = RG 'Transfer Range Data to Array
Cnt = 0
Debug.Print LBound(InArr, 1) & " - " & UBound(InArr, 1) 'Rows
Debug.Print LBound(InArr, 2) & " - " & UBound(InArr, 2) 'Columns
For Y = 1 To UBound(InArr, 1) 'For Each Row in Array (or each Y position)
For X = 1 To UBound(InArr, 2) 'For Each Column in Array (or each X position)
If InArr(Y, X) <> "" Then 'If not blank Value (you can change this to "If InArr(Y, X) <> 0 Then" if that works best for you.
Cnt = Cnt + 1 'Increment "found value count" by 1
OutArr(Cnt) = InArr(Y, X) 'Add found value to output array
End If
Next X
Next Y
'Output to Dest Sheet
DestinationSheet.Range("F2").Resize(UBound(OutArr, 1), 1).Value = Application.Transpose(OutArr())
End Sub
Based on the information in your previous comments, try these alternative solution using formulas and filters...
1) Array Formulas
To note:
I have put everything on one sheet for clarity, but it works just as well over multiple sheets, or even workbooks.
If you want to filter the entire sheet, with same column order, you only need to enter formula once and expand "Array" criteria in formula to encapsulate entire data set.
Formula used in cell "J4" = "=FILTER($I$4:$I$30,$C$4:$C$30>0)"
(filter range I4 to I30 to show rows where value in range C4 to C30 is greater than 0)
2) Directly Filter
Alternatively, you could (either manually or programmatically) copy all data to LOB sheet, (or selectively copy), then filter for Qty>0.

Why is my array returning empty? And how do I ensure it copies the data into my third selection

After countless efforts to keep the array "newvarray" within range, I am now running into a result of an empty array from a 278 line column. I believe this is also the root cause of my endgame function not executing (pasting unmatched values into the rolls sheet)?
Clarification: the actualy empty cells report on locals as "Empty", the columns with string report as " "" "
Dim oldsht As Worksheet
Dim newsht As Worksheet
Dim rollsht As Worksheet
Dim a As Integer
Dim b As Integer
Dim c As Integer
Set oldsht = ThisWorkbook.Sheets("Insert Yesterday's Report Here")
Set newsht = ThisWorkbook.Sheets("Insert Today's Report Here")
Set rollsht = ThisWorkbook.Sheets("Rolls")
Dim OldVArray(), NewVArray(), RollArray() As String
ReDim Preserve OldVArray(1 To oldsht.Range("a" & Rows.Count).End(xlUp).Row - 1, 5 To 5)
ReDim Preserve NewVArray(2 To newsht.Range("a" & Rows.Count).End(xlUp).Row, 5 To 5)
ReDim Preserve RollArray(1 To rollsht.Range("a" & Rows.Count).End(xlUp).Row - 1, 3 To 3)
For a = 2 To oldsht.Range("E" & Rows.Count).End(xlUp).Row
OldVArray(a, 5) = oldsht.Cells(a, 5)
Next a
For b = 2 To newsht.Range("E" & Rows.Count).End(xlUp).Row
NewVArray(b, 5) = newsht.Cells(b, 5)
Next b
For c = 2 To rollsht.Range("C" & Rows.Count).End(xlUp).Row
RollArray(c, 3) = rollsht.Cells(c, 3)
Next c
Dim Voyage As String
For a = 2 To UBound(OldVArray)
Voyage = OldVArray(a, 5)
For b = 2 To UBound(NewVArray)
voyage2 = NewVArray(b, 5)
If voyage2 <> Voyage Then
If voyage2 <> "" Then
For Each cell In NewVArray
voyage2 = rollsheet.Range("C:C")
Next
End If
End If
Next
Next
Here are snips of sample idea, highlighted are the rows that need to be found, and the voyage that changed is in orange. Third on Rolls would be the output of the macro.
Oldsheet:
Newsheet:
Rolls:
Untested, but this is how I'd do it. Just going from your screenshots. If your actual data looks different then you will need to make some adjustments.
Sub test()
Dim wb As Workbook, oldsht As Worksheet, newsht As Worksheet, rollsht As Worksheet
Dim c As Range, id, col, cDest As Range, copied As Boolean, m
Set wb = ThisWorkbook
Set oldsht = wb.Sheets("Insert Yesterday's Report Here")
Set newsht = wb.Sheets("Insert Today's Report Here")
Set rollsht = wb.Sheets("Rolls")
'next empty row on Rolls sheet
Set cDest = rollsht.Cells(Rows.Count, "A").End(xlUp).Offset(1)
'loop colA on new sheet
For Each c In newsht.Range("A2:A" & newsht.Cells(Rows.Count, "A").End(xlUp).row).Cells
id = c.Value 'identifier from Col A
If Len(id) > 0 Then
m = Application.Match(id, oldsht.Columns("A"), 0) 'check for exact match on old sheet
If Not IsError(m) Then
'got a match: check for updates in cols B to C
copied = False
For col = 2 To 3
If c.EntireRow.Cells(col).Value <> oldsht.Cells(m, col).Value Then
If Not copied Then 'already copied this row?
cDest.Resize(1, 3).Value = c.Resize(1, 3).Value 'copy changed row
Set cDest = cDest.Offset(1) ' next empy row
copied = True
End If
cDest.EntireRow.Cells(col).Interior.Color = vbRed 'flag updated value
End If
Next col
Else
cDest.Resize(1, 3).Value = c.Resize(1, 3).Value 'copy new row
Set cDest = cDest.Offset(1) ' next empy row
End If
End If
Next c
End Sub

Excel VBA: Update a cell based on conditions

I am not that much familiar in VBA code. I am looking to implement two scenarios using VBA code in excel.
Scenario 1: If the value in the "C" column contains specific text, then replace the corresponding values in the "A" column as below
If the value in C contains "abc" then A= "abc".
If the value in C contains "gec" then A= "GEC".
It should loop from the second row to last non-empty row
A
B
C
Two
abc-def
Thr
gec-vdg
Thr
abc-ghi
Expected Result:
A
B
C
abc
Two
abc-def
gec
Thr
gec-vdg
abc
Thr
abc-ghi
Scenario 2: If the value in the "B" column is "A", then replace all the "A" value in the B column as "Active". If the value in the "B" column is I", then replace all the I value in the B column as inactive.
It should loop from the second row to last non-empty row
A
B
C
abc
A
abc-def
gec
I
gec-vdg
abc
A
abc-ghi
Expected Result:
A
B
C
abc
Active
abc-def
gec
Inactive
gec-vdg
abc
Active
abc-ghi
I know that it is possible by using excel formulas. Wondering, how it can be implemented using vba code in excel.
Usually people on here won't just write code for you, this is more for helping you with your code when your stuck. However I've written one for you based on the information you have provided. I've assumed your cells in column C would always have the hyphen and you always want what's left of the hyphen. If there is no hyphen or the relevant cell in column C is empty then nothing will be put into the relevant cell in column A.
I've put in to turn off ScreenUpdating for the code as I don't know how many rows you have. If it's a lot and you have a lot going on, then we can also turn off Calculation and Events to speed it up more, or run it as an array if it's really slow but I suspect that it won't be an issue.
Paste this into your relevant sheet module and change the sheet name as well as the column that's finding the last row if C isn't the right one:
Sub UpdateCells()
Application.ScreenUpdating = False
Dim i As Long, lRow As Long, ws As Worksheet
Set ws = Sheets("Sheet1") 'Change Sheet1 to your sheet name
lRow = ws.Range("C" & Rows.Count).End(xlUp).Row 'Finds your last row using Column C
With ws
For i = 2 To lRow 'Loop from row 2 to last row
If .Range("B" & i) = "A" Then
.Range("B" & i) = "Active"
ElseIf .Range("B" & i) = "I" Then
.Range("B" & i) = "Inactive"
End If
If .Range("C" & i) <> "" Then
If InStr(.Range("C" & i), "-") > 0 Then 'If current row Column C contains hyphen
.Range("A" & i) = Left(.Range("C" & i), InStr(.Range("C" & i), "-") - 1)
End If
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Replace Values
Option Explicit
Sub replaceCustom()
' Define constants.
Const wsName As String = "Sheet1"
Const ColumnsAddress As String = "A:C"
Const FirstRow As Long = 2
Dim Contains As Variant: Contains = VBA.Array(3, 1) ' 0-read, 1-write
Const findContainsList As String = "abc,gec" ' read
Const replContainsList As String = "abc,gec" ' write
Dim Equals As Variant: Equals = VBA.Array(2, 2) ' 0-read, 1-write
Const findEqualsList As String = "A,I" ' read
Const replEqualsList As String = "Active,Inactive" ' write
Dim CompareMethod As VbCompareMethod: CompareMethod = vbTextCompare
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Define range.
Dim rng As Range
With wb.Worksheets(wsName).Columns(ColumnsAddress)
Set rng = .Resize(.Worksheet.Rows.Count - FirstRow + 1) _
.Offset(FirstRow - 1).Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then
Exit Sub
End If
Set rng = .Resize(rng.Row - FirstRow + 1).Offset(FirstRow - 1)
End With
' Write values from range to array.
Dim Data As Variant: Data = rng.Value
' Write lists to arrays.
Dim findCo() As String: findCo = Split(findContainsList, ",")
Dim replCo() As String: replCo = Split(replContainsList, ",")
Dim findEq() As String: findEq = Split(findEqualsList, ",")
Dim replEq() As String: replEq = Split(replEqualsList, ",")
' Modify values in array.
Dim i As Long
Dim n As Long
For i = 1 To UBound(Data, 1)
For n = 0 To UBound(Contains)
If InStr(1, Data(i, Contains(0)), findCo(n), CompareMethod) > 0 Then
Data(i, Contains(1)) = replCo(n)
Exit For
End If
Next n
For n = 0 To UBound(Equals)
If StrComp(Data(i, Equals(0)), findEq(n), CompareMethod) = 0 Then
Data(i, Equals(1)) = replEq(n)
Exit For
End If
Next n
Next i
' Write values from array to range.
rng.Value = Data
End Sub

Split zip code in a column into 2 columns

This is what my end result should look like. If there is not the four digits to move over to the second column then fill with 4 zeros.
How can I split zip code in a column into 2 columns and fill empty cells in column 2 if first column has only 5 digits?
Here is what I have been working with
Dim ws As Worksheet
Dim cell As Range
Set ws = Worksheets("sheet1")
For Each cell In ws.Range("K2:K500").Cells
cell.Offset(0, 1).Value = Left(cell.Value, 5)
Next cell
Dim cel As Range, rngC As Range, rngB As Range
Dim lastRowA As Long, lastRowB As Long
With ws
lastRowK = .Cells(.Rows.Count, "K").End(xlUp).Row 'last row of column A
lastRowL = .Cells(.Rows.Count, "L").End(xlUp).Row 'last row of column B
For Each cel In .Range("K2:K" & lastRowL) 'loop through column L
'check if cell in column A exists in column B
If WorksheetFunction.CountIf(.Range("K2:K" & lastRowL), cel) = 0 Then
cel.Offset(0, 3).Value = Right(cel.Value, 4)
'.Range("M" & cel.Row) = Right(cell.Value, 4)
Else
.Range("M" & cel.Row) = "0000"
End If
Next
End With
In case you want to bypass VBA and use formulas, you can do this.
Cell B2:
=LEFT(A2,5)
Cell C2:
=IF(LEN(A2)=9,RIGHT(A2,4),"0000")
One of the simplest ways to solve this problem is to supplement the original string with a large number of zeros and take the values ​​of the first and second five characters for two cells:
Sub setZIPandZeros()
Const TEN_ZEROS = "0000000000" ' 10 times
Dim ws As Worksheet
Dim cell As Range
Dim sLongString As String
Set ws = Worksheets("Sheet1")
For Each cell In ws.Range("K2:K" & ws.Cells(ws.Rows.Count, "K").End(xlUp).Row).Cells
sLongString = Trim(cell.Text) & TEN_ZEROS
cell.Offset(0, 1).Resize(1, 2).NumberFormat = "#"
cell.Offset(0, 1).Resize(1, 2).Value = Array(Left(sLongString, 5), _
Mid(sLongString, 6, 5))
Next cell
End Sub
Update The modified code is much faster and gives a result that more closely matches the description of the task:
Sub setZipZeros()
Dim ws As Worksheet
Dim rResult As Range
Set ws = Worksheets("Sheet1")
' Addressing R1C1 is used in the formulas - If the original range
' is shifted to another column, you will need to change the letter
' of the column "K" only in this line
Set rResult = ws.Range("K2", ws.Cells(ws.Rows.Count, "K").End(xlUp)).Offset(0, 1)
' If the columns L:M are already in text format, then instead of
' the results we will get the texts of formulas
rResult.Resize(, 2).NumberFormat = "General"
' These two lines do most of the work:
rResult.Formula2R1C1 = "=LEFT(TRIM(RC[-1])&""00000"",5)"
rResult.Offset(0, 1).Formula2R1C1 = "=MID(TRIM(RC[-2])&""000000000"",6,4)"
' We don't know if auto-recalculation mode is on now
' Application.Calculation = xlAutomatic
ActiveSheet.Calculate
Set rResult = rResult.Resize(, 2)
' Set the text format for the cells of the result
' to prevent conversions "00123" to "123"
rResult.NumberFormat = "#"
' Replace formulas with their values
rResult.Value = rResult.Value
End Sub

Resources