I have a sheet, S and P. In Sheet S, I have few ID starting with D2E and few Id starting with 4 in Column N.
I am comparing the ID, containing 4, with sheet P in column L. If they match, then I am writing the ID of sheet P from column A in Column N.
I have few case below in the snapshot, which I am not able to extract. Could any one help me , how I can do that
In sheet S , I have an Id like 41035036_drw_000_draf , in sheet P I am able to find the corresponding D2E number and I got it printed, but I want this number to be printed in my sheet S of column P.
I believe that I need to modify the rng.find function. that I it looks for first 8 character. Could any one help, how I can do that
Below is my code
Sub drwmatch()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim cell As Range, cell2 As Range, lstcl As Variant, lstcl2 As Variant, rgFnd As Variant
Dim n As Double, ID As String
Dim a As String
Dim b As Variant
Set sh1 = ThisWorkbook.Sheets("S")
Set sh2 = ThisWorkbook.Sheets("P")
' ID starts with number 4
ID = "4"
lstcl = sh1.Range("N10000").End(xlUp).Row
lstcl2 = sh2.Range("L10000").End(xlUp).Row
'comparing columns N and L in both sheets
For Each cell In sh2.Range("L5:L" & lstcl2)
For n = 5 To lstcl
a = Left(sh1.Range("N" & n), 8)
If cell = a Then
'the cell in column M next to the matching cell is equal to the 4xxxxxxx number
cell.Offset(0, 1) = a
'the next cell in column N is equal to the A2C number in column A
cell.Offset(0, 2) = cell.Offset(0, -11)
End If
Next
Next
'test that each cell in the first sheet corresponds to the located results in the second sheet _
'and pastes back the A2C number, using the Range.Find function
For Each cell2 In sh1.Range("N5:N" & n)
If Left(cell2, 1) = ID Then
Set rgFnd = sh2.Range("M5:M" & lstcl2).Find(cell2.Value)
If Not rgFnd Is Nothing Then
cell2.Offset(0, 1) = sh2.Range(rgFnd.Address).Offset(0, 1)
End If
End If
Next
End Sub
to have a search on the first 8 chars you could write your find instruction like this
Set rgFnd = sh2.Range("M5:M" & lstcl2).Find(Left(cell2.Value, 8), lookat:=xlPart)
Related
I have two Sheets sheet1, sheet2
With sheet1 i have id which always starts with 4, I look for this ID in sheet2, and pul the corresponding names and copy back to sheet1.
The ID is always 8 Digit Long.
during this , I have an Special case, where an ID has some Special charachters and charachters. eg: 41017734_dr_bad ; the code Fails in this case. I doesnot recognise the first 8 and Fails to paste in the another sheet.
Could someone suggest how to overcome this?
I have an idea we could use whilcard and also strlen function. But struck how to use in code.
Sub match()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim cell As Range, cell2 As Range, lstcl As Variant, lstcl2 As Variant, rgFnd As Variant
Dim n As Double, ID As String
Set sh1 = ThisWorkbook.Sheets("S")
Set sh2 = ThisWorkbook.Sheets("P")
ID = "4"
lstcl = sh1.Range("N10000").End(xlUp).Row
lstcl2 = sh2.Range("L10000").End(xlUp).Row
'comparing columns N and L in both sheets
For Each cell In sh2.Range("L5:L" & lstcl2)
For n = 5 To lstcl
If cell = sh1.Range("N" & n) Then
'the cell in column M next to the matching cell is equal to the 4xxxxxxx number
cell.Offset(0, 1) = sh1.Range("N" & n)
'the next cell in column N is equal to the A2C number in column A
cell.Offset(0, 2) = cell.Offset(0, -11)
End If
Next
Next
'test that each cell in the first sheet corresponds to the located results in the second sheet _
'and pastes back the A2C number, using the Range.Find function
For Each cell2 In sh1.Range("N5:N" & lstcl)
If Left(cell2, 1) = ID Then
Set rgFnd = sh2.Range("M5:M" & lstcl2).Find(cell2.Value)
If Not rgFnd Is Nothing Then
cell2.Offset(0, 1) = sh2.Range(rgFnd.Address).Offset(0, 1)
End If
End If
Next
End Sub
Try this
Sub match()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim cell As Range, cell2 As Range, lstcl As Variant, lstcl2 As Variant, rgFnd As Variant
Dim n As Double, ID As String
Set sh1 = ThisWorkbook.sheets("S")
Set sh2 = ThisWorkbook.sheets("P")
ID = "4"
lstcl = sh1.Range("N10000").End(xlUp).Row
lstcl2 = sh2.Range("L10000").End(xlUp).Row
'comparing columns N and L in both sheets
For Each cell In sh2.Range("L5:L" & lstcl2)
For n = 5 To lstcl
a = Left(sh1.Range("N" & n), 8)
If cell = a Then
'the cell in column M next to the matching cell is equal to the 4xxxxxxx number
cell.Offset(0, 1) = a
'the next cell in column N is equal to the A2C number in column A
cell.Offset(0, 2) = cell.Offset(0, -11)
End If
Next
Next
'test that each cell in the first sheet corresponds to the located results in the second sheet _
'and pastes back the A2C number, using the Range.Find function
For Each cell2 In sh1.Range("N5:N" & lstcl)
If Left(cell2, 1) = ID Then
Set rgFnd = sh2.Range("M5:M" & lstcl2).Find(cell2.Value)
If Not rgFnd Is Nothing Then
cell2.Offset(0, 1) = sh2.Range(rgFnd.Address).Offset(0, 1)
End If
End If
Next
End Sub
What I want to do: Iterate over values on one page to check for match on another page and if a match is found take a value from 2nd page same row but different column.
I've been trying now for quite some time. I'm new to VBA-scripting / Excel and might be approaching the problem incorrectly, hence why I'm asking here!
My code so far:
Sub InsertData()
ScreenUpdating = False
Dim wks As Worksheet
Dim subSheet As Worksheet
Set subSheet = Sheets("Sheet4")
Dim rowRangeSub As Range
Dim LastRowSub As Long
LastRowSub = subSheet.Cells(subSheet.Rows.Count, "C").End(xlUp).Row
Set rowRangeSub = subSheet.Range("C2:C" & LastRowSub)
Dim subGroupList As ListObject
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRow As Long
Dim Found As Range
'START OF SHEET1'
Set wks = Sheets("SHEET1")
LastRow = wks.Cells(wks.Rows.Count, "B").End(xlUp).Row
Set rowRange = wks.Range("B2:B" & LastRow)
'Loop through each row in B column (Names)'
For Each rrow In rowRange
If Not IsEmpty(rrow) Then
With Sheets("Sheet4").Range("C2:C" & LastRowSub)
Set Found = .Find(What:=rrow, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Found Is Nothing Then
'Debug.Print "Found"'
wks.Cells(rrow.Row, "K").Value = "Found"
Else
wks.Cells(rrow.Row, "K").Value = "Not Found"
'Debug.Print "Not Found"'
End If
End With
End If
Next rrow
'END OF SHEET1'
'START OF SHEET2'
Set wks = Sheets("SHEET2")
LastRow = wks.Cells(wks.Rows.Count, "B").End(xlUp).Row
Set rowRange = wks.Range("B2:B" & LastRow)
'END OF SHEET2'
'START OF SHEET3'
Set wks = Sheets("SHEET3")
LastRow = wks.Cells(wks.Rows.Count, "B").End(xlUp).Row
Set rowRange = wks.Range("B2:B" & LastRow)
'END OF SHEET3'
ScreenUpdating = True
End Sub
The setup in the Excel file is as such:
The three sheets, Sheet1, Sheet2, Sheet3 contains a lot of data in its 10 first columns (A-J) and the 11th column (K) is where the data is to be inserted if it is found. Pertinent data, names, is found in column B where B:1 is just "Name" as a title. There is also some empty cells in the column to take into consideration.
The 4th sheet, Sheet4 contains some data in its 5 first columns. The names which are to be matched can be found in column C, and if a match is found it is supposed to collect data from the Cells(Found.Row, "E") where "E" is column E.
This problem has been screwing with my head quite a lot since .Find()-function seems to not work as I expect it to, as in it finds the opposites sometimes.
My main question is: How do I assign the correct value to the row?
wks.Cells(rrow.Row, "K").Value = rowRangeSub.Cells(Found.Row, "E").Value
I feel like I've tested at least 10 different ways to assign, but I keep on getting error after error. Most of the time it's a missmatch error.
Any help is appreciated!
EDIT since reading comments:
Ok, here it goes :
All columns are formatted as text.
Column A: Personal numbers: not relevant
Column B: Names: Form is: Lastname, Firstname. This is to be used when searching for a match.
Column C to J not relevant with various information about a person.
Column K: This columns cell starts out empty. This is to be filled by the macro.
I have three different books within the Excel file that have data that looks like what I've explained, just different data in each book.
The 4th book is as such:
Column A and B is not relevant with info not needed at all.
Column C: Is the names in form Lastname, Firstname. This is what should be the column cells to compare with column B's cells in the other books.
Column D: Not relevant
Column E: This is the important part of Sheet4. For every person there is a "group number" that can be found in this column for every row.
What I want to do is compare each cell in column B in Sheet1-3 for a match in column C in Sheet4. If a match is found (not all are assigned a group, so matches might not be found) then take cell information from Sheet4 on the row which a match was found and column "E", put this information in the row in Sheet1-3 and column "K".
Example data (is there a way to submit tables?):
Sheet1:
COLUMN B
Tablesson, Pen
Paper, Ink
Eraser, Screen
COLUMN K is at this moment empty
Sheet4:
COLUMN C
Paper, Ink
Eraser, Screen
COLUMN E
55
77
RUNS THE MACRO, Sheet1 after macro:
COLUMN B
Tablesson, Pen
Paper, Ink
Eraser, Screen
COLUMN K
[First entry is empty since no match was found]
55
77
Hopefully this is understandable!
I simplified the process by using a Scripting Dictionary.
Sub InsertData()
Dim lastRow As Long, x As Long
Dim dicNames, k As String, v As Variant
Set dicNames = CreateObject("scripting.dictionary")
'Create list of Names to compare against and values to update
With Worksheets("Sheet4")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lastRow
k = .Cells(x, 3).Value 'Name from Column C
v = .Cells(x, 5).Value 'Value From Column E
'Add Key Value pairs to Dictionary
If Not dicNames.Exists(k) Then dicNames.Add k, v
Next
End With
ProcessWorksheet Worksheets("Sheet1"), dicNames
ProcessWorksheet Worksheets("Sheet2"), dicNames
ProcessWorksheet Worksheets("Sheet3"), dicNames
End Sub
Sub ProcessWorksheet(ws As Worksheet, ByRef dicNames)
Dim k As String, v As Range
Dim lastRow As Long, x As Long
With ws
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lastRow
k = .Cells(x, 2) 'If Name from Column B
If dicNames.Exists(k) Then
.Cells(x, 11) = dicNames(k) 'Then Column K = Value from Sheet4
End If
Next
End With
End Sub
Sub InsertData()
Dim lastRow As Long, x As Long
Dim dicNames, k As String, v As Variant
Set dicNames = CreateObject("scripting.dictionary")
'Create list of Names to compare against and values to update
With Worksheets("Sheet4")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lastRow
k = .Cells(x, 3).Value 'Name from Column C
v = .Cells(x, 5).Value 'Value From Column E
'Add Key Value pairs to Dictionary
If Not dicNames.Exists(k) Then dicNames.Add k, v
Next
End With
ProcessWorksheet Worksheets("Sheet1"), dicNames
ProcessWorksheet Worksheets("Sheet2"), dicNames
ProcessWorksheet Worksheets("Sheet3"), dicNames
End Sub
Sub ProcessWorksheet(ws As Worksheet, ByRef dicNames)
Dim k As String, v As Range
Dim lastRow As Long, x As Long
With ws
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lastRow
k = .Cells(x, 2) 'If Name from Column B
If dicNames.Exists(k) Then
.Cells(x, 11) = dicNames(k) 'Then Column K = Value from Sheet4
End If
Next
End With
End Sub
Basically used the code provided by Thomas Inzina with minor changes:
If dicNames.Exists(k) Then
newV = IIf(dicNames(k) = v, v, dicNames(k) & "," & v)
dicNames.Remove (k)
dicNames.Add k, newV
Else
dicNames.Add k, v
End If
This takes duplicates into consideration.
I also used this cleaning function since I couldn't find the built-in one in VBA. Used them as such:
k = CleanTrim(.Cells(X, 3).Value) 'Name from Column C
k = CleanTrim(.Cells(X, 2).Value) 'If Name from Column B
I'm new in VBA coding, and would really appreciate some help solving this problem.
I need to do as follows:
Compare every value in column G, Worksheet1, to the Unique values in column D, Worksheet2.
If a value matches, copy from that row values in column: C, G & I
Paste every match into Worksheet3
I've tried this so far:
Sub test()
Application.ScreenUpdating = False
Dim rng1 As Range, rng2 As Range, rngName As Range, i As Integer, j As Integer
For i = 1 To Sheets("Worksheet1").Range("G" & Rows.Count).End(xlUp).Row
Set rng1 = Sheets("Worksheet1").Range("G" & i)
For j = 1 To Sheets("Worksheet2").Range("D" & Rows.Count).End(xlUp).Row
Set rng2 = Sheets("Worksheet2").Range("D" & j)
Set rngName = Sheets("Worksheet1").Range("H" & j)
If rng1.Value = rng2.Value Then
rngName.Copy Destination:=Worksheets("Worksheet3").Range("B" & i)
End If
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i
End Sub
But it doesn't work.
There is a problem with this statement:
Set rngName = Sheets("Worksheet1").Range("H" & j)
The variable j refers to a row in Worksheet2, but you use it on Worksheet1. Depending on what you intended here, you should either change the worksheet name or use the variable i instead of j.
Assuming it is the first, the code could also be written as:
Dim rng1 As Range, rng2 As Range
' Iterate over the used cells in the G column of Worksheet1
For Each rng1 In Sheets(1).UsedRange.Columns(8 - Sheets(1).UsedRange.Column).Cells
' Iterate over the used cells in the D column of Worksheet2
For Each rng2 In Sheets(2).UsedRange.Columns(5 - Sheets(2).UsedRange.Column).Cells
If rng1.Value = rng2.Value Then
' Copy value from the C column in Worksheet2 to the B column in Worksheet3
Sheets(3).Cells(rng2.Row, 2).Value = rng2.Offset(0, -1).Value
End If
Next
Next
Alternative to VBA code
Instead of using code, you could do this with formulas.
For instance in Worksheet3 you could put this formula in B1:
=INDEX(Worksheet2!$C:$C, MATCH(Worksheet1!$G1,Worksheet2!$D:$D, 0))
Here is an explanation of the two main parts of that formula:
MATCH(Worksheet1!$G1, Worksheet2!$D:$D, 0)
This part will take the value from Worksheet1!$G1, find it in Worksheet2!$D:$D (i.e. the complete D column) and return the row number where it was found. The last argument (0) makes sure that only exact matches count.
INDEX(Worksheet2!$C:$C, ...)
The row number returned by MATCH will be used to get a value from the C column of Worksheet2, at that same row.
You can change that $C:$C by $H:$H to get the value from the H column, etc.
Drag/copy the formula downwards to repeat it for other rows.
I would use the Cells property and a Do loop to loop through G on WS1. Try something like this:
Dim i as Integer, j as Integer
Dim c as Range
i = 2 'Will be used to loop through WS1, Column G
j = 1 'Will be used to find next empty row in WS3
Do Until Sheets(1).Cells(i, 7).Value = ""
Set c = Sheets(2).Range("D2")
Do Until c.value = Sheets(1).Cells(i, 7).Value Or c.value = ""
Set c = c.Offset(1, 0)
Loop
If c.value = Sheets(1).Cells(i, 7).Value Then
'Find first empty row in WS3
j = 1
Do Until Sheets(3).Cells(j, 1).Value = ""
j = j + 1
Loop
'Copy row
Sheets(3).Rows(j).value = Sheets(1).Rows(I).value
End if
i = i + 1
Loop
Set c = Nothing
I have 2 workbooks: "MainWorkbook.xlsm" and "ReferenceWorkbook.xlsx". The reference workbook is a report that the main workbook pulls data from.
There is a column in my main workbook called "Vendor Name", which is column J. The column in the reference workbook that "Vendor Name" would be referencing is column X, named "Vendor_Data". Both of the vendor columns in the 2 worksheets are non-numeric data types. Furthermore, both of these worksheets are subject to variations in row counts; I may have 200 rows in "Mainworkbook.xlsm" one day and 230 the next. The same applies for "ReferenceWorkbook". The vendor column in "MainWorkbook.xlsm" will remain static as far as it's index value goes, but the position of the vendor column in ReferenceWorkbook.xlsx could potentially change in the future (ex. going from column x to column y). The header row in "MainWorkbook") is row 2, while the header row in "ReferenceWorkbook" is row 1.
What I would like to do is build a macro that will automatically populate my vendor column in "MainWorkbook" by first matching to the vendor column in "ReferenceWorkbook" based on their headers and then matching rows by their primary keys (Column C in "MainWorkbook" and column K in "ReferenceWorkbook"). The primary key column in "ReferenceWorkbook" is also subject to having it's column index changed, like it's vendor column, so I would like to do all of my header matching based on header names, not their index values.
Since I'm just starting out with VBA, the best I have so far is an incomplete and very logically flawed block of code:
Sub New_Macro()
Dim ran As Range, source_header As Range, target_header As Range
Dim source As Workbook, source_sheet As Worksheet, target As Workbook, target_sheet As Worksheet
Dim i As Integer, j As Integer, Match_header As Integer
Set source = Application.Workbooks("ReferenceWorkbook.xlsx")
Set Reference_sheet = source.Worksheets("ReferenceSheet")
Set target = Application.Workbooks("MainWorkbook.xlsm")
Set target_sheet = target.Worksheets("MainSheet")
Set source_worksheet_header = source_sheet.Range("X1")
Set target_worksheet_header = target_sheet.Range("J2")
LR = target_sheet.Cells(Rows.Count, 1).End(xlUp).Row
j = 10
Set ran = target_sheet.Range("J3" & LR)
ran.ClearContents
Do While j < 11
For Each cell In target_worksheet_header
For i = 3 To LR
Match_header = source_worksheet_header.Find(cell.Value)
target_sheet.Cells(i, j).Value = Application.WorksheetFunction.Index(source_sheet.Range("X"), WorksheetFunction.Match(target_sheet.Cells(i, 10).Value, source_sheet.Range("X"), LR), Match_header)
On Error Resume Next
Next i
j = j + 1
Next cell
Loop
End Sub
Does anyone have a way to turn this into an actual solution? Any help would be wonderous
Compiled but not tested:
Sub New_Macro()
Dim ran As Range, c As Range
Dim source_sheet As Worksheet
Dim target_sheet As Worksheet
Dim srcVendorCol As Range, srcIdCol As Range, f As Range
Dim vndr, r, id
Dim LR As Long
Set source_sheet = Workbooks("ReferenceWorkbook.xlsx") _
.Worksheets("ReferenceSheet")
Set target_sheet = Workbooks("MainWorkbook.xlsm") _
.Worksheets("MainSheet")
Set f = source_sheet.Rows(1).Find(what:="Vendor_Data", _
lookat:=xlWhole, LookIn:=xlValues)
If Not f Is Nothing Then
Set srcVendorCol = f.EntireColumn
End If
Set f = Nothing
Set f = source_sheet.Rows(1).Find(what:="PrimaryKey", _
lookat:=xlWhole, LookIn:=xlValues)
If Not f Is Nothing Then
Set srcIdCol = f.EntireColumn
End If
If srcVendorCol Is Nothing Or srcIdCol Is Nothing Then
MsgBox "Required column headers not found in source sheet!"
Exit Sub
End If
'find last populated cell in Col J
LR = target_sheet.Cells(Rows.Count, "J").End(xlUp).Row 'EDIT
Set ran = target_sheet.Range("J3:J" & LR)
For Each c In ran.Cells
id = c.EntireRow.Cells(3).Value
If Len(id) > 0 Then 'EDIT - added check for Id length
r = Application.Match(id, srcIdCol, 0)
If Not IsError(r) Then
c.Value = Application.Index(srcVendorCol, r, 1)
Else
c.Value = "Id not found"
End If
End If
Next c
End Sub
I have a worksheet with ~700 rows, and 7 columns. I need each row to have just one entry. I.e. if row 1 has cell values in column A,B and C, then two new rows should be created so row 1 has one value in column A, row 2 has one value in column B and row 3 has one value in column C.
I have spent a couple hours on this (sadly) but I'm so bad, I'm not getting anywhere:
Sub TThis()
Dim rng As Range
Dim row As Range
Dim cell As Range
'just testing with a basic range
Set rng = Range("A1:C2")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Value <> "" Then
'write to adjacent cell
Set nextcell = cell.Offset(1, 0)
nextcell.Value = cell.Value
nextcell.EntireRow.Insert
End If
Next cell
Next row
End Sub
My issue is that this code deletes the row beneath it (which is not suppose to happen)
and it inserts two rows instead of one.
Thanks a ton!
I'd read your data into an array, delete the data on the worksheet, and then write back to the worksheet in a single column (whilst checking for blanks)
Example:
Sub OneColumnData()
Dim rng As Range, ids As Range, arr() As Variant, rw As Integer, col As Integer, counter As Integer
Set rng = Range("A1:C5")
Set ID = Range("G1:G5")
arr = rng.Value
counter = 1
rng.ClearContents
For rw = 1 To UBound(arr, 1)
For col = 1 To UBound(arr, 2)
If arr(rw, col) <> vbNullString Then
Range("A" & counter) = arr(rw, col)
Range("B" & counter) = ID(rw)
counter = counter + 1
End If
Next col
Next rw
End Sub