Ive been searching left and right but seem to only find bits and pieces. i'm unable to combine these into the solution i need.
My workbook has a list of items on the first sheet, the partnumbers in column A have to be searched for in Column A of a second sheet and if they exist there, those rows need to be copied to a third sheet.In steps i'm looking to do the following:
Column A of sheet1 (called "input") has several partnumbers.
After clicking CommandButton2 on sheet1, all partnumbers in Column A (starting in cell A5)should be searched for in Column A of sheet3 (called "partlists", starting in A2).
If found here, for all the respective rows where the partnumbers match: columns C to G("partlists") should be copied to sheet2("picklist") column A below the last row, the value in column E("picklist") has to be multiplied with the value in Column E("input") AND columns G to K("input") copied to the respective rows column G("Picklist")
If not found on "partlists", copy entire row from "input" to "picklist" below last row.
So far i've got the following code:
Sub InputPickMatch()
Dim LR As Long, i As Long, lngNextRow As Long, LookUpListInput As Range, LookUpListParts As Range
Set LookUpListInput = Sheets("Input").Range("A:A") 'lookup list Input
Set LookUpListParts = Sheets("Partlists").Range("A:A")
With Sheets("Input")
LR = .Cells(Rows.Count, "A").End(xlUp).Row 'last row
For i = 5 To LR
If IsError(Application.Match(.Cells(i, "A").Value, LookUpListParts, 0)) Then
.Range(Cells(i, "A").Address(), Cells(i, "D").Address()).Copy
Sheets("Picklist").Select
lngNextRow = Sheets("Picklist").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Picklist").Range("A" & lngNextRow).PasteSpecial _
Paste:=xlPasteValues
.Range(Cells(i, "F").Address(), Cells(i, "K").Address()).Copy
Sheets("Picklist").Range("E" & lngNextRow).PasteSpecial _
Paste:=xlPasteValues
End If
Next i
End With
With Sheets("Partlists")
LR = .Cells(Rows.Count, "A").End(xlUp).Row 'last row
For i = 3 To LR
If IsNumeric(Application.Match(.Cells(i, "A").Value, LookUpListInput, 0)) Then
.Range(Cells(i, "C").Address(), Cells(i, "G").Address()).Copy
Sheets("Picklist").Select
lngNextRow = Sheets("Picklist").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Picklist").Range("A" & lngNextRow).PasteSpecial _
Paste:=xlPasteValues
'Sheets("Picklist").Cells(lngNextRow, "E") = Sheets("Input").Cells(LookUpListInput, "E") * .Cells(i, "G") 'NOT WORKING: Multiply row from lookuplist column E with .Cells(i, "G")
'Sheets("Input").Range(Cells(LookUpList, "G").Address(), Cells(LookUpListInput, "K").Address()).Copy 'NOT WORKING: Copy row from lookuplist column G:K
'Sheets("Picklist").Range("F" & lngNextRow).PasteSpecial 'Paste Picklist column G
End If
Next i
End With
End Sub
It's working ok up to where i try to multiply and copy from the lookup list.
Hopefully someone can help
I got it guys
Sub InputToPicklist()
Dim LR As Long, i As Long, lngNextRow As Long, LookUpListInput As Range, LookUpListParts As Range
Dim Matchres As Variant
Set LookUpListInput = Sheets("Input").Range("A:A")
Set LookUpListParts = Sheets("Partlists").Range("A:A")
With Sheets("Input")
LR = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 5 To LR
If IsError(Application.Match(.Cells(i, "A").Value, LookUpListParts, 0)) Then
lngNextRow = Sheets("Picklist").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Picklist").Range(Cells(lngNextRow, "A").Address(), Cells(lngNextRow, "D").Address()).Value = .Range(Cells(i, "A").Address(), Cells(i, "D").Address()).Value
Sheets("Picklist").Range(Cells(lngNextRow, "E").Address(), Cells(lngNextRow, "J").Address()).Value = .Range(Cells(i, "F").Address(), Cells(i, "K").Address()).Value
End If
Next i
End With
With Sheets("Partlists")
LR = .Cells(Rows.Count, "A").End(xlUp).Row 'last row
For i = 3 To LR
If IsNumeric(Application.Match(.Cells(i, "A").Value, LookUpListInput, 0)) Then
lngNextRow = Sheets("Picklist").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Picklist").Range(Cells(lngNextRow, "A").Address(), Cells(lngNextRow, "E").Address()).Value = .Range(Cells(i, "C").Address(), Cells(i, "G").Address()).Value
Matchres = Application.Match(.Cells(i, "A").Value, LookUpListInput, 0)
Sheets("Picklist").Cells(lngNextRow, "E") = Sheets("Input").Cells(Matchres, "F") * .Cells(i, "G") 'Multiply row from lookuplist column E with .Cells(i, "G")
Sheets("Picklist").Range(Cells(lngNextRow, "F").Address(), Cells(lngNextRow, "J").Address()).Value = Sheets("Input").Range(Cells(Matchres, "G").Address(), Cells(Matchres, "K").Address()).Value 'Copy row from lookuplist column G:K
End If
Next i
End With
Sheets("Input").Range("A5:K138").ClearContents
End Sub
First
Dim Matchres As Variant
and calling it
Matchres = Application.Match(.Cells(i, "A").Value, LookUpListInput, 0)
Does the trick
Sub NewMacro()
Dim endRow As Long
endRow = Sheet1.Range("A999999").End(xlUp).Row
For i = 1 To endRow
If Sheet1.Range("A" & i).Value = Sheet1.Range("F" & i).Value Then
Sheet1.Range("K" & i).Value = "Yes" Else
Sheet1.Range("K" & i).Value = "No"
End If
Next i
End Sub
This will compare column A with column F and displays the result in column K.
What I need is if this value is true, then like the above it should compare column B with column G, column C with column H and so on......and should display the results in next column. Please help.
I think you need a loop on the columns:
Sub NewMacro()
Dim endRow As Long
Dim i As Long
Dim c As Long
With Sheet1
endRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To endRow
For c = 1 To 5
If .Cells(i, c).Value = .Cells(i, c + 5).Value Then
.Cells(i, c + 10).Value = "Yes"
Else
.Cells(i, c + 10).Value = "No"
End If
Next c
Next i
End With
End Sub
This compares column A with F, column B with G, column C with H, column D with I and column E with J. Results are placed in columns K, L, M, N and O respectively.
This is equivalent to using the formula =IF(A1=F1,"Yes","No") in cell K1 and copying it across and down.
And a version which will update columns with "Yes", but stop as soon as it reaches a "No":
Sub NewMacro()
Dim endRow As Long
Dim i As Long
Dim c As Long
With Sheet1
endRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To endRow
For c = 1 To 5
If .Cells(i, c).Value = .Cells(i, c + 5).Value Then
.Cells(i, c + 10).Value = "Yes"
Else
.Cells(i, c + 10).Value = "No"
Exit For
End If
Next c
Next i
End With
End Sub
I have 8000 rows of data in column A.
I am trying to write code that would scan the rows and each time there's a cell formatted as bold, to determine a range that includes that cell and all cells in the subsequent rows until the next bold cell. This range should be copied to column B, tranposed.
Here's the code that I have so far:
Sub Sorting()
Application.ScreenUpdating = False
last_row = ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Row
y = 1
For i = 1 To LastRow
If Range("A" & i).Font.Bold = True Then
Range("A" & i).Copy Range("A" & i + 9)
Range("B" & y).PasteSpecial Transpose:=True
y = y + 1
x = i
Else
Range("A" & x).Copy Range("B" & i)
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub doIt()
Dim a1 As Range: Set a1 = Range("A1")
Dim a2 As Range: Set a2 = a1.Offset(1)
Dim b As Range: Set b = Range("B1")
Do Until Intersect(a2, ActiveSheet.UsedRange) Is Nothing
If a2.Font.Bold Then
b.Resize(, a2.row - a1.row) = Application.Transpose(Range(a1, a2.Offset(-1)))
Set a1 = a2: Set a2 = a1.Offset(1): Set b = b.Offset(1)
Else
Set a2 = a2.Offset(1)
End If
Loop
b.Resize(, a2.row - a1.row) = Application.Transpose(Range(a1, a2.Offset(-1)))
End Sub
I keep getting this error on the line with Application.WorksheetFunction and from reading on the topic for hours I feel that I've gotten just about nowhere.
Does it have something to do with the way I'm referencing Sheet2? Or am I not understanding fully what Application.WorksheetFunction is supposed to do?
Sub SearchForValues()
i = 4 'starts the iterator at column D
Do While Cells(1, i) <> ""
Dim l As Long, searchRange As String
n = 2
Do While Range("A" & n) <> "" 'loop until the last row of data in the first column
StartRow = Range("B" & n)
EndRow = Range("C" & n)
searchRange = "A" & StartRow & ":Q" & EndRow
l = Application.WorksheetFunction.Match(Cells(1, i), Worksheets("Sheet2").Range(searchRange), 0)
Range("D" & n) = l
n = n + 1
Loop
i = i + 1
Loop
End Sub
Here's a screenshot of the data I have. Columns B and C are the ranges of rows that I want to search in on Sheet2 for each row on sheet 1 and each cell across the top is a term I want to search for in that range.
Scott Craner already answered your question in his comments with "
Match only works on 1 dimensional arrays; either one row or one column" and "Use the VBA Find()".
Here is an example of how you can use Range.Find
Sub SearchForValues()
Application.ScreenUpdating = False
Dim Target As Range
Dim x As Long, y As Long
With Worksheets("Sheet1")
For x = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
For y = 4 To .Cells(1, .Columns.Count).End(xlToLeft).Column
Set Target = Worksheets("Sheet2").Range("A" & .Cells(x, "B").Value & ":Q" & .Cells(x, "C").Value)
.Cells(x, y).Value = Not Target.Find(.Cells(1, y).Value) Is Nothing
Next
Next
End With
Application.ScreenUpdating = True
End Sub
I have multiple Excel workbooks that contain about 8,000 rows so it would be nice to use a macro.
Basically, if any row has a zero (0) in all columns (at the same time) B, D, E, I, J, and K it will delete.
Here is what I have so far...way too new with VB to figure out.
Sub DeleteRowsZeros()
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step -1
If (Range("B") = "0" And Range("D" & i) = "0" And Range("E" & i) = "0" And Range("I" & i) = "0" _
And Range("J" & i) = "0" And Range("K" & i) = "0") Then Rows(i).Delete
Next i
End Sub
Try this :
Sub DeleteRowsZeros()
Dim cell As Range, notZeroColumns As Range, row As Range
Set row = Range("A" & Rows.Count).End(xlUp).EntireRow.Offset(1, 0)
Set notZeroColumns = Range("B:B,D:E,I:k")
While row.row <> 1
Set row = row.Offset(-1, 0)
For Each cell In Intersect(row, notZeroColumns)
If cell.Text <> "0" Then GoTo continueLbl
Next
row.Offset(1, 0).Delete
continueLbl:
Wend
End Sub
EDIT : bugfixe