I have a question regarding this post (VBA copy rows that meet criteria to another sheet)
His script:
Sub LastRowInOneColumn()
'Find the last used row in a Column: column A in this example
Worksheets("Sheet2").Activate
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
MsgBox (LastRow)
For i = 1 To LastRow
If Worksheets("Sheet2").Cells(i, 1).Value = "X" Then
ActiveSheet.Row.Value.Copy _
Destination:=Hoja1
End If
Next i
End Sub
I wonder if there are multiple conditions in just 1 If statement. The idea is to copy and paste data to another sheet if column1 = "X", or column2 ="Y", or (column1 = "X" and column2 = "Y").
I changed by myself and run, but the output sheet looks quite weird.
If Worksheets("Sheet2").Cells(i, 1).Value = "X" Or _
Worksheets("Sheet2").Cells(i, 2).Value = "Y" Or _
(Worksheets("Sheet2").Cells(i, 1).Value = "X" And _
Worksheets("Sheet2").Cells(i, 2).Value = "Y") Then
Related
I have a sheet with Columns A to P.
In columns B i have customer names. Want to find rows with substring “ABC -“ and copy the content of the cell in column B to Column G on the same row.
My code fails on this:
For I= 1 to finalrow
If Left(Cells(I,2).Value,5) = “ABC -“ Then
Rownumber= ActiveCell.Row
Range("B" & Rownumber).Select
Range("B" & Rownumber).Copy
Range("G" & rownumber).Select
ActiveSheet.Paste
Range("G" & rownumber).Select
End if
Next I
This one works as expected, writing the values from column "B" to column "G":
Sub TestMe()
Dim i As Long
For i = 1 To 10
With ThisWorkbook.Worksheets("Sheet1")
Dim myCell As Range
Set myCell = .Cells(i, "B")
If Trim(Left(myCell.Value, 5)) = "ABC -" Then
.Cells(i, "G").Value = myCell.Value
End If
End With
Next i
End Sub
Try to avoid .Select and .Activate - https://stackoverflow.com/a/35864330/5448626
Use Trim()
Using . and referring the worksheet is always a good practice
.Cells(i, "B") improves readability
“ probably should be "
For I = 1 To finalrow
With Cells(I, 2)
If .Text Like "ABC -*" Then .Offset(0, 5) = .Value
End With
Next I
For I = 1 to finalrow
If Left(Cells(I,2).Value,5) = "ABC -" Then
Cells(I,7).Value = Cells(I,2).Value
End if
Next I
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
Need help, If statement not providing desired result. Values in the comparing cells are the same but the if argument works half the time. Code provided below
Sub autofilter1()
For b = 1 To 4
' Last row of unique values - Unique Tab
lr = Sheets("Unique").Cells(Rows.Count, b).End(xlUp).Row
'Tabs = c
ws_count = ActiveWorkbook.Worksheets.Count
For c = 2 To ws_count
'Last row of column A
lr1 = Sheets(c).Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
'Execution of auto filter program
Sheets(c).Range("A1:A" & lr1).autofilter Field:=1, Criteria1:=Sheets("Unique").Range("A" & i)
'Last row of Filtered visible cells
lr2 = Sheets(c).Cells(Rows.Count, 4).End(xlUp).Row
'Below line selects entire range of visible cells
'Sheets("Assets").Range("D2:D" & lr2).SpecialCells(xlCellTypeVisible).Select
'Selection of Cell to identify aggregate address 1) Range definition, 2) sub-class aggregate cell identifier
With Sheets(c).autofilter.Range
Range("D" & .Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Select
End With
'Dynamic Sum function home
Selection.Offset(0, 1).Select
'First cell below primary (only in case of multiple sub accounts, else primary is account)
SS = Selection.Offset(1, -1).Address
'Final cell of dynamic autofilter range
SE = ("D" & lr2)
Rng = Sheets(c).Range(SS & " : " & SE).SpecialCells(xlCellTypeVisible)
ActiveCell = Application.WorksheetFunction.Sum(Rng)
If ActiveCell.Value = ActiveCell.Offset(0, -1).Value Then
ActiveCell.Offset(0, 1) = "True"
ActiveCell.Offset(0, 1).Font.Bold = True
ActiveCell.Offset(0, 1).Interior.Color = 5296274
Else
ActiveCell.Offset(0, 1) = "False"
ActiveCell.Offset(0, 1).Font.Bold = True
ActiveCell.Offset(0, 1).Interior.Color = 255
End If
Next i
Next c
Next b
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
I have been searching an efficient way to copy data from one spreadsheet to another and always paste one row below. Someone helped me with this code, but unfortunately it is not working for the columns i need. So I need to copy data from E2:P2 on sheet "Dividends" and paste firstly on C11:N11, then tomorrow if I run again should paste on C12:N12 and always one row below... When I run the code, it pastes the data on C111:N111, and if I run again still paste on the same range, so does not work for me. I would appreciate your help.
Sub Copy_range()
' edit line below to change where data will be copied from
Worksheets("Dividends").Range("E2:P2").Copy ' copy the value
' select the first cell on the "Draft" sheet
Worksheets("Draft").Select
ActiveSheet.Range("C11").Select
Dim count As Integer
count = 1
'skip all used cells
Do While Not (ActiveCell.value = None)
ActiveCell.Offset(1, 0).Range("C11").Select
count = count + 1
Loop
Worksheets("Draft").Range("C11" & count & ":N11" & count).PasteSpecial ' paste the value
End Sub
Using ActiveCell and Offset can often lead to unexpected results and makes the code hard to read. You can have the counting loop working without all of this, by simply going through column C cells starting at C11 and looking for empty one.
One of possible ways is
Sub Copy_range
Dim count As Integer
count = 11
Do While Worksheets("Draft").Range("C" & count).Value <> ""
'<>"" means "is not empty", as long as this happens we go down looking for empty cell
count = count + 1
Loop
'Now count is row with first empty cell outside of top 10 rows in column C
Worksheets("Dividends").Range("E2:P2").Copy
Worksheets("Draft").Range("C" & count).PasteSpecial xlPasteValues
End Sub
I would say that you could most likely just solve this with a Vlookup Formula autofilled to the target area. But the below code should do it.
Option Explicit
Sub moveDividends()
Dim wsF As Worksheet 'From
Dim wsD As Worksheet 'Destination
Dim i As Long
Dim LastRow As Long
Set wsF = ThisWorkbook.Sheets("Sheet1")
Set wsD = ThisWorkbook.Sheets("Sheet2")
With wsD
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
Else
LastRow = 1
End If
End With
With wsD
LastRow = LastRow + 1
wsD.Cells(LastRow, "C").Value = wsF.Cells(2, 5).Value
wsD.Cells(LastRow, "D").Value = wsF.Cells(2, 6).Value
wsD.Cells(LastRow, "E").Value = wsF.Cells(2, 7).Value
wsD.Cells(LastRow, "F").Value = wsF.Cells(2, 8).Value
wsD.Cells(LastRow, "G").Value = wsF.Cells(2, 9).Value
wsD.Cells(LastRow, "H").Value = wsF.Cells(2, 10).Value
wsD.Cells(LastRow, "I").Value = wsF.Cells(2, 11).Value
wsD.Cells(LastRow, "J").Value = wsF.Cells(2, 12).Value
wsD.Cells(LastRow, "K").Value = wsF.Cells(2, 13).Value
wsD.Cells(LastRow, "L").Value = wsF.Cells(2, 14).Value
wsD.Cells(LastRow, "M").Value = wsF.Cells(2, 15).Value
wsD.Cells(LastRow, "N").Value = wsF.Cells(2, 16).Value
End With
End Sub
all method are rigth, or simply use:
Sub Copy_range()
Dim lastRow As Long
' edit line below to change where data will be copied from
Worksheets("Dividends").Range("E2:P2").Copy ' copy the value
' find the 1th not-used rows
lastRow = Worksheets("Draft").Cells(1048576, 3).End(xlUp).Row + 1
lastRow = IIf(lastrows < 11, 11, lastrows) 'optional if is possible that the rows 10, 9, 8,.... are empty
Worksheets("Draft").Range("C" & lastRow).PasteSpecial xlPasteValues ' paste the value
End Sub
Use the below
Sub Copy_range()
' edit line below to change where data will be copied from
Worksheets("Dividends").Range("E2:P2").Copy ' copy the value
'count cells and add 1 for next row
last_row = Worksheets("Draft").Range("C" & Worksheets("Draft").Rows.Count).End(xlUp).Row + 1
If last_row > 1000000 Then last_row = 1
Worksheets("Draft").Range("C" & last_row ).PasteSpecial
' paste the value only need to ref first cell
End Sub