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
Related
Following code is suggested by a helpful user, this works well to Calculate "From", "To", "MAX" etc values of a range. But this code gives results in every row of a range. I want to get the results in only first row of each row. Please help with this.
Sub trial()
Dim lastrow As Long
Dim destSht As Worksheet
Dim i As Long, j As Long
Set destSht = Worksheets("Final")
With Worksheets("Source")
lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 2 To lastrow + 1 'loop whole range (column C)
If .Cells(i, "C") <> "" Then 'If column C is not empty then
For j = i To lastrow + 1 'Loop "group" range to find next empty cell. Start from current loop i to last row and add one row to get to next empty cell.
If .Cells(j, "C") = "" Then 'When next empty cell is found (i.e. end of small group range) then apply formulas
.Cells(i, "E").Value = .Cells(i, "B").Value 'From
.Cells(i, "F").Value = .Cells(j - 1, "B").Value 'To
.Cells(i, "G").Formula = "=MAX(C" & i & ":C" & j - 1 & ")" 'MAX
.Cells(i, "H").Formula = "=MIN(C" & i & ":C" & j - 1 & ")" 'MIN
.Cells(i, "I").Formula = "=AVERAGE(C" & i & ":C" & j - 1 & ")" 'AVG
Exit For
End If
Next j
End If
Next I
End With
End Sub
This Code gives following result
Desired Result
Try changing this line:
If .Cells(i, "C") <> "" Then 'If column C is not empty then
To this line:
If .Cells(i, "C") <> "" AND .Cells(i-1, "C") = "" Then 'If column C is not empty AND the column C above is empty then
Hope You are all Safe
I'm trying to calculate MAX, MIN and AVG Values of filled cells which are continued without blank cell (As you can see it in the left side of the sample image ).
I'm facing problem in selecting these randomly placed cells and calculate the above values and also "From" and "To" values of respective range.
Please let me know how to do it. So far I've constructed following code
Dim Cel As Range
Dim lastrow As Long
Dim destSht As Worksheet
Set destSht = Worksheets("Final")
With Worksheets("Source")
lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
For Each Cel In .Range("C2:C" & lastrow)
If .Cells(Cel.Row, "C") <> "" Then
Cel.Offset(0, -1).Copy Destination:=destSht.Cells(destSht.Rows.Count, 1).End(xlUp).Offset(0, 1)
'It will give "From" Column
'' Plz suggest for "To" Column
Range("G5").Select
ActiveCell.FormulaR1C1 = "=MAX(RC[-4]:R[4]C[-4])" 'It will give values "MAX" Column
Range("H5").Select
ActiveCell.FormulaR1C1 = "=MIN(RC[-5]:R[4]C[-5])" 'It will give values "MIN" Column
Range("I5").Select
ActiveCell.FormulaR1C1 = "=AVERAGE(RC[-6]:R[4]C[-6])" 'It will give values "AVG" Column
End If
Next
Did some quick, which should work.
I don't know what you want to do in the "Final" worksheet, so haven't focused on that line.
Logic is to have one big loop (For i...) that go through the whole Column C. When a value is found in column C (If .Cells(i, "C") <> "" Then), we perform a "small loop" (For j = i To lastrow + 1) to check next empty cell to decide the "small group" range. When that range is decided we perform the To, From, MAX, MIN and AVG formulas, which has to be dynamic.
Option Explicit
Sub trial()
Dim lastrow As Long
Dim destSht As Worksheet
Dim i As Long, j As Long
Set destSht = Worksheets("Final")
With Worksheets("Source")
lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 2 To lastrow + 1 'loop whole range (column C)
If .Cells(i, "C") <> "" Then 'If column C is not empty then
For j = i To lastrow + 1 'Loop "group" range to find next empty cell. Start from current loop i to last row and add one row to get to next empty cell.
If .Cells(j, "C") = "" Then 'When next empty cell is found (i.e. end of small group range) then apply formulas
.Cells(i, "E").Value = .Cells(i, "B").Value 'From
.Cells(i, "F").Value = .Cells(j - 1, "B").Value 'To
.Cells(i, "G").Formula = "=MAX(C" & i & ":C" & j - 1 & ")" 'MAX
.Cells(i, "H").Formula = "=MIN(C" & i & ":C" & j - 1 & ")" 'MIN
.Cells(i, "I").Formula = "=AVERAGE(C" & i & ":C" & j - 1 & ")" 'AVG
Exit For
End If
Next j
End If
Next i
End With
End Sub
Result:
I am trying to write a VBA code for an Excel macro so that I can manually trigger the macro to do the following:
In the event that any two rows have:
Same value in column A
Same value in Column B
"apple" in Column C
Same value in Column D
Then I would like all of those rows to be deleted except the row with the highest value in column E.
As an example, if:
cell A1 = cell A2
cell B1 = cell B2
cell C1 and Cell C2 = "apple"
cell D1 = cell D2
Cell E1 = 5 and Cell E2 = 10
Then Row 1 gets deleted and Row 2 remains.
The overall goal is to delete similar rows.
Per a user's suggestions, this process can be aided/simplified by sorting range by c="apple",a,b,d so that rows can be analyzed consecutively.
Example of Code Outcome
I put together the following code, but I am unfamiliar with the delete row aspect and how to incorporate the highest value, but this was my best shot. The If and elseif statements are questionable.
Sub Macro()
Dim a As Range
Dim b As Range
Dim c As Range
Dim d As Range
Dim e As Range
For Each a In Range("A1:A9999")
For Each b In Range("B1:B9999")
For Each c In Range("C1:C9999")
For Each d In Range("D1:D9999")
For Each e In Range("E1:E9999")
If a.Offset(-1, 0) = a And b.Offset(-1, 0) And c.Offset(-1, 0) = c And d.Offset(-1, 0) = d And e.Offset(-1, 0) < e Then Range(a).EntireRow.Delete
ElseIf a.Offset(-1, 0) = a And b.Offset(-1, 0) And c.Offset(-1, 0) = c And d.Offset(-1, 0) = d And e.Offset(-1, 0) > e Then Range(a.Offset(-1, 0)).EntireRow.Delete
Exit For
Next a
Next b
Next c
Next d
Next e
End Sub
I hope it works.
Option Explicit
Sub RunMacro()
Dim i As Long, LastRow As Long, j As Long
Dim cellA, cellB, cellC, cellD, cellE
Dim Rng As Range
LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
cellA = Range("A" & i).Value
cellB = Range("B" & i).Value
cellC = Range("C" & i).Value
cellD = Range("D" & i).Value
cellE = Range("E" & i).Value
For j = LastRow To 2 Step -1
If Range("A" & j).Value = cellA And Range("B" & j).Value = cellB Then
If Range("C" & j).Value = cellC And Range("D" & j).Value = cellD Then
If cellE > Range("E" & j).Value Then
Range("E" & j).EntireRow.Delete
LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
End If
End If
End If
Next j
Next i
LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
With ActiveSheet
Set Rng = Range("A1", Range("E1").End(xlDown))
Rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlYes
End With
End Sub
I'm trying to copy a cell and the adjacent cell in a row and insert it as a new row with all the data to the right of this cell also copied over. My data looks like this after mining.
and im trying to get my data to look like this:
the image above is just one record but essentially its moving all the people and their corresponding position in the original row to a new row. In each row there are about 5 employees and their positions.
thanks
EDIT Attempted code for just 2 cols. 1 position. the idea was to create the empty rows and just copy the rest of the data with auto fill, then work from there
Sub TransposeInsertRows()
Dim rng As Range
Dim i As Long, j As Long, k As Long
Dim x As Long, y As Long
Set rng = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Enter the name col and pos col", Type:=8)
Application.ScreenUpdating = False
x = rng(1, 1).Column + 2
y = rng(1, rng.Columns.Count).Column
For i = rng(rng.Rows.Count, 1).Row To rng(1, 1).Row Step -1
If Cells(i, x) <> "" And Cells(i, x + 1) <> "" Then
k = Cells(i, x - 2).End(xlToRight).Column
If k > y Then k = y
For j = k To x + 1 Step -1
Cells(i + 1, 1).EntireRow.Insert
With Cells(i + 1, x - 2)
.Value = .Offset(-1, 0)
.Offset(0, 1) = .Offset(-1, 1)
.Offset(0, 2) = Cells(i, j)
End With
Cells(i, j).ClearContents
Next j
End If
Next i
Application.ScreenUpdating = True
End Sub
If there are always 5 people in each row then this should do it:
Sub foo()
LastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow 'loop through rows
For x = 1 To 10 Step 2 'loop through columns
LastRow2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row + 1 'find the next free row on Sheet2
Sheet2.Cells(LastRow2, 1).Value = Sheet1.Cells(i, x).Value 'add Person Name to Sheet2
Sheet2.Cells(LastRow2, 2).Value = Sheet1.Cells(i, x + 1).Value 'add position to Sheet2
Sheet1.Range("K" & i & ":U" & i).Copy Destination:=Sheet2.Cells(LastRow2, 3) 'copy range from K to U to Sheet2
Next x
Next i
End Sub
I need to scan Col B for any values that have the same left characters that are found in cell AL2, the length of the string is found in AR1. If the left value in Col B matches the value in AL2 I need to copy the values in that row from Col B to col G. copied into Col At, starting a AT6 and continuing down until there until all values in Col C have been checked. First picture is data that will be scanned, second picture is what I want the macro to spit out
Here is the modified macro that I recorded. I am getting an runtime 13 error on the IF statement. Any ideas on how to clean this up ?
Sub GenerateSummaryPage()
'
' scans B column for combiner box numbers
Application.ScreenUpdating = False
Dim dlen As String
Worksheets("HR-Cal").Activate
dlen = Worksheets("HR-Cal").Range("AR2")
r = ActiveCell.Row
For lrow = Cells(Cells.Rows.Count, "B").End(xlUp).Row To 7 Step -1
'checks curent row for box name in cell AL2
'copies values from col B to col G in that row to into Col AT, starting at AS6
If Left(Cells(lrow, "B"), dlen) = ActiveSheet.Range("AL2").Text Then Range("B" & r).Rows.Select
'If Left(Cells(lrow, "B"), dlen) = Range("AL2").Value Then Range("B" & r & ":G" & r).Select
Selection.Copy
Range("AT100000").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteAll)
Next lrow
Application.ScreenUpdating = True
'insert rows for inverter headers
End Sub
You should try this.
If Left(Cells(lrow, "B"), dlen) = ActiveSheet.Range("AL2").Text Then
Range(Cells(lrow, "B"), Cells(lrow, "G")).Value = Range(Cells(lrow, "AT"), Cells(lrow, "AY")).Value
End if
If this doesn't work you, before the if you could try to check the value of lrow and dlen to make to sure they have a correct value.
Let me know if that works for you
Assuming you don't need formatting, I think you want something like this...
Dim ws As Worksheet
Set ws = ThisWorkbook.WorkSheets("HR-Cal")
dlen = 2 'change this
lrow = ws.Cells(Cells.Rows.Count, "B").End(xlUp).Row
For i = 7 To lrow
'checks curent row for box name in cell AL2
'copies values from col B to col G in that row to into Col AT, starting at AS6
If Left(Cells(i, "B"), dlen) = ws.Range("M2").Text Then 'change M2
'Range("B" & i).Rows.Select
'If Left(Cells(lrow, "B"), dlen) = Range("AL2").Value Then Range("B" & r & ":G" & r).Select
'Selection.Copy
Range(Cells(i, 10), Cells(i, 15)).Value = Range(Cells(i, 2), Cells(i, 7)).Value 'change columns
'Range("AT100000").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteAll)
End If
Next i