I have the following code which will copy/paste some columns from "data" worksheet and pastes to the next empty column in to the column that i specify in the mastersheet called "KomKo".
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("data")
Set pasteSheet = Worksheets("KoMKo")
lRow = copySheet.Cells(copySheet.Rows.Count, 1).End(xlUp).Row
With copySheet.Range("BX2:BX" & lRow)
pasteSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count) = .Value
End With
Now i would like to add an if condition for another column; which should say "if column U in Worksheet "data" has cell value "8636" then these values should be pasted to Column H in Worksheet "KomKo"(pastesheet); to the next row as i used the code above in the "with" part.
Else( If the value in Column H is not 8636) then it should paste the value inside this column to Column G at Worksheet "KomKo"(pastesheet) with same preferences as above again.
How can i do this ?
So, I've come up with a suggestion below using an if-then within a loop. I think it's close to what you want...
Sub try6()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim x As Range
Set ws = Worksheets("data")
Set ws2 = Worksheets("KomKo")
For Each x In ws.Range("C1:C100")
If x.Value = 8636 Then
ws2.Range("H:H").Value = ws.Cells(Rows.Count, "A").Value
ElseIf x <> 8636 Then
ws2.Range("G:G").Value = ws.Range(Rows.Count, "B").Value
End If
Next x
End Sub
Testing it, it took a while to execute. I'd say, set a dynamic range at something like A10000 and copy it directly without needing to necessarily test for whether there is a value in the range being copied.
You can also use the Select method for the purpose and copy the selection - from personal experience, I've had mixed success with it and I've seen people advise against using it here.
These are my .02, hope it helps! Cheers.
Related
Just started learning VBA today to try to make life a bit easier at my new job. I'm essentially trying to look for every instance where column E has the letter "a" copy and paste it into a newly created worksheet called "Aton" then delete the original rows with the "a"s.
I tried to modify the solution found here: VBA: Copy and paste entire row based on if then statement / loop and push to 3 new sheets
When I changed the above solution to make this line "If wsSrc.Cells(i, "E").Value = "a" Then" that's when I run into problems.
Sub Macro3()
'Need "Dim"
'Recommend "Long" rather than "Integer" for referring to rows and columns
'i As Integer
Dim i As Long
'Declare "Number"
Dim Number As Long
'Declare a variable to refer to the sheet you are going to copy from
Dim wsSrc As Worksheet
Set wsSrc = ActiveSheet
'Declare a variable to refer to the sheet you are going to copy to
Dim wsDest As Worksheet
'Declare three other worksheet variables for the three potential destinations
Dim wsEqualA As Worksheet
'Create the three sheets - do this once rather than in the loop
Set wsEqualA = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'Assign the worksheet names
wsEqualA.Name = "Aton"
'Determine last row in source sheet
Number = wsSrc.Cells(wsSrc.Rows.Count, "C").End(xlUp).Row
For i = 1 To Number
'Determine which destination sheet to use
If wsSrc.Cells(i, "E").Value = "a" Then
Set wsDest = wsEqualA
Else
End If
'Copy the current row from the source sheet to the next available row on the
'destination sheet
With wsDest
wsSrc.Rows(i).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
'Delete row if column E has an a
If wsSrc.Cells(i, "E").Value = "a" Then
Selection.EntireRow.Delete
Else
End If
Next i
End Sub
Sticking to your code, you have three issues
when deleting rows you have to loop backwards and avoid skipping rows
you’re copying and (trying to) deleting rows outside the ‘If wsSrc.Cells(i, "E").Value = "a"‘ block, hence regardless of current row “i” column E value
you don’t want to delete currently selected range rows, but currently loop “i” row
Putting it all together here’s the correct relevant snippet;
Set wsDest = wsEqualA 'set target sheet once and for all outside the loop
For i = Number To 1 Step -1 'Loop backwards
If wsSrc.Cells(i, "E").Value = "a" Then
'Copy the current row from the source sheet to the next available row on the destination sheet
With wsDest
wsSrc.Rows(i).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) 'Copy wsSrc current “i” row and paste it to wsDest
wsSrc.Rows(i).Delete 'Delete wsSrc current “i” row
End With
End If
Next
As a possible enhancement, you could swap the sheets references in the “With...End With” block, since it’s more effective to reference the mostly “used” one:
With wsSrc
.Rows(i).Copy wsDest.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) 'Copy wsSrc current “i” row and paste it to wsDest
.Rows(i).Delete 'Delete wsSrc current “i” row
End With
You need to qualify which sheet the original values are on. Change Sheet on the line Set ws = ThisWorkbook.Sheets("Sheet1") to your sheet name.
Create new sheet and set objects
Create range to loop through, LoopRange (E2 down to last row in column)
Loop through LoopRange. If criteria is met, add the cell, MyCell, to a collection of cells (TargetRange)
If the TargetRange is not empty (meaning your criteria was met at least once) then copy header from ws to ns
Copy TargetRange from ws to ns
Delete TargetRange from ws
The benifit if using Union to collect cells is that you avoid many iterations of copy/paste/delete. If you have 50 cells in your range that meet your criteria, you will have 50 instance each for copy/paste/delete for a grand total of 150 actions.
Using the Union method, you will just have 1 instance for each action for a grand total of 3 actions which will boost run time.
Option Explicit
Sub Learning()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim ns As Worksheet: Set ns = Worksheets.Add(After:=(ThisWorkbook.Sheets.Count)) 'ns = new sheet
ns.Name = "Aton"
Dim LoopRange As Range, MyCell As Range, TargetRange As Range
Set LoopRange = ws.Range("E2:E" & ws.Range("E" & ws.Rows.Count).End(xlUp).Row)
For Each MyCell In LoopRange 'Loop through column E
If MyCell = "a" Then
If TargetRange Is Nothing Then 'If no range has been set yet
Set TargetRange = MyCell
Else 'If a range has already been set
Set TargetRange = Union(TargetRange, MyCell)
End If
End If
Next MyCell
Application.ScreenUpdating = False
If Not TargetRange Is Nothing Then 'Make sure you don't try to copy a empty range
ws.Range("A1").EntireRow.Copy ns.Range("A1") 'copy header from original sheet
TargetRange.EntireRow.Copy ns.Range("A2")
TargetRange.EntireRow.Delete
Else
MsgBox "No cells were found in Column E with value of 'a'"
End If
Application.ScreenUpdating = True
End Sub
First, don't use ActiveSheet, it can cause multiple problems. If sheet1 is not your source worksheet then change it to meet your needs. I prefer using a filter, as urdearboy suggested, which dosn't require a loop and is faster. I always try to keep the code simple, so try this...
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Aton"
With Sheet1.UsedRange
.AutoFilter Field:=5, Criteria1:="a", Operator:=xlFilterValues
.Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheets("Aton").Range("A1")
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
I am trying to process excel data dumped from quickbooks. In order to do what I want, I need to use first non blank row in column A, which varies depending on the period reported in quickbooks.
I am using
Sub Test()
Selection.End(xlDown).Select
to find the first non blank row in column A.
Say for example I have two files, one where the first non blank cell in column A is A157. Selection.End(xlDown).Select selects A157. I then need to select C1:C157.
The other spreadsheet has the first non blank cell in column A at A122. Selection.End(xlDown).Select selects A122. I then need to select C1:C122. The row in column A found using xlDown is a variable that I then need to use to create a selection in column C.
Any help is much appreciated. Thank you!
To get last row/column in a worksheet try:
Dim ws As Worksheet
set ws = ActiveSheet
With ws
lastRow = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
lastCol = ws.Cells.SpecialCells(xlCellTypeLastCell).Column
End With
To get last row/column in a range try:
Dim rg as Range
With ws
Set rg = .Range(.Cells(1, 3), .Cells(999, 3))
With rg
lastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
lastCol = .Cells.SpecialCells(xlCellTypeLastCell).Column
End With
End With
To set new range for your last row/column try:
With ws
Set rg = .Range(.Cells(firstRow, firstCol), .Cells(lastRow, lastCol))
End With
If you have more than 1 worksheet you can specify multiple sheets simply like this:
Dim ws(3) As Worksheet
set ws(0) = Worksheets("SheetName1");
set ws(1) = Worksheets("SheetName2");
'etc.
Try,
dim rng as range
set rng = range(cells(1, "C"), cells(activecell.end(xldown).row, "C"))
rng.select
I have a problem, but my VBA is novice and can't figure out what's going wrong with my code.
What I'm trying to achieve is:
Step 1. In Sheet 1 I have lots of data beneath the headings in cells B8:BR8
Step 2. I filter on cell BE8 for non-blanks
Step 3. I copy the filtered data beneath BE8:BN8 (excluding the headings and I don't need all of the data hence I'm just copying a subset of the full data)
Step 4. I go to Sheet 2 where I have a populated table with headings in C8:L8 that correspond exactly to the headings BE8:BN8 from Sheet 1
Step 5. I want to append this new copied set of data to the end of this table in Sheet 2
Step 6. I want to go back to Sheet 1 and delete some of the filtered data, specifically those under headings BE8,BK8:BN8
Here's my attempt which I've tried to adapt from another code:
Sub TransferData()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim RngBeforeFilter As Range, RngAfterFilter As Range
Dim LCol As Long, LRow As Long
With ThisWorkbook
Set WS1 = .Sheets("Sheet1")
Set WS2 = .Sheets("Sheet2")
End With
With WS1
'Make sure no other filters are active.
.AutoFilterMode = False
'Get the correct boundaries.
LRow = .Range("BE" & .Rows.Count).End(xlUp).Row
LCol = .Range("BE8:BN8").Column
'Set the range to filter.
Set RngBeforeFilter = .Range(.Cells(1, 2), .Cells(LRow, LCol)).Offset(1)
RngBeforeFilter.Rows(8).AutoFilter Field:=56, Criteria1:="<>"
'Set the new range, but use visible cells only.
Set RngAfterFilter = .Range(.Cells(1, 7), .Cells(LRow, LCol)).SpecialCells(xlCellTypeVisible)
'Copy the visible cells from the new range.
RngAfterFilter.Copy WS2.Range("C65536").End(xlUp)
'Clear filtered data (not working)
Sheets("Sheet1").Range("B8", Range("B8").End(xlDown)).SpecialCells(xlCellTypeVisible).ClearContents
.ShowAllData
End With
End Sub
I would appreciate any help that you could provide.
Thanks
Jacque
A few problems here:
.Range("BE8:BN8").Column
probably isn't doing what you expect - it will just return the column number of BE (ie 57).
RngBeforeFilter is doing nothing - you can just use
.Rows(8).AutoFilter Field:=56, Criteria1:="<>"
You say you want to copy data in BE:BN, but you start RngAfterFilter from column A (ie .Cells(1, 7)).
WS2.Range("C65536").End(xlUp)
gives the last row used, whereas you'll want to paste into the next row down.
You're clearing column B, rather than columns BE, BK and BN.
As such, try this instead:
Sub TransferData()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim RngBeforeFilter As Range, RngAfterFilter As Range
Dim BECol As Long, BNCol As Long, LRow As Long
With ThisWorkbook
Set WS1 = .Sheets("Sheet1")
Set WS2 = .Sheets("Sheet2")
End With
With WS1
'Make sure no other filters are active.
.AutoFilterMode = False
'Get the correct boundaries.
LRow = .Range("BE" & .Rows.Count).End(xlUp).Row
BECol = .Range("BE8").Column
BNCol = .Range("BN8").Column
'Set the range to filter.
.Rows(8).AutoFilter Field:=BECol - 1, Criteria1:="<>"
'Set the new range, but use visible cells only.
Set RngAfterFilter = .Range(.Cells(9, BECol), .Cells(LRow, BNCol)).SpecialCells(xlCellTypeVisible)
'Copy the visible cells from the new range.
RngAfterFilter.Copy WS2.Range("C65536").End(xlUp).Offset(1)
'Clear filtered data
.Range("BE9", Range("BE8").End(xlDown)).SpecialCells(xlCellTypeVisible).ClearContents
.Range("BK9", Range("BK8").End(xlDown)).SpecialCells(xlCellTypeVisible).ClearContents
.Range("BN9", Range("BN8").End(xlDown)).SpecialCells(xlCellTypeVisible).ClearContents
.ShowAllData
End With
End Sub
I have to find and replace rows in sheet 1 given matching cell value in the same column in sheet2. The column number is 4.
HELPPP!!!
This is what I have right now and I get an error on next x.
Sub DeleteRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Set wb = ActiveWorkbook
Set ws = Sheets(Sheet1)
Set ws2 = Sheets(sheet2)
With wb
For i = 1 To ws2.Cells(Rows.Count, 4).End(xlUp).Row
Dim lookupvalue As String
lookupvalue = ws2.Cells(i, 4).Value
For x = 1 To ws1.Cells(Rows.Count, 4).End(xlUp).Row
Dim rng As range
For Each rng In range("D:D")
If InStr(1, rng.Value, "lookupvalue") > 0 Then
rng.Delete
End If
Next x
exitloop:
Next i
End With
End Sub
As A.S.H. said, the code needs a little improvement:
1) The two inner loops need to be combined.
2) The new inner loop should go from the bottom up, due to the fact that you are deleting the cell, This is probably why you have the second inner loop but that just adds time to the sub.
3) you are currently only deleting the one cell at a time, any data around it will remain. This may be what you want and so I left it, but if you meant to delete the entire row then uncomment the line that does that.
4) when testing with the instr function the variable should not be in quotes, with the variable in quotes it will look for that specific word "lookupvalues" and not the value assigned to that variable.
5) The with block that was being used did nothing. when using the with block the line that use it need to start with a '.' for example: on your code the with was with the workbook so every time a worksheet is used it should start with a "." like .ws1... and so forth. But by declaring the sheets using the workbook, this is no longer needed.
Sub DeleteRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim lookupvalue As String
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("sheet2")
For i = 1 To ws2.Cells(Rows.Count, 4).End(xlUp).Row
lookupvalue = ws2.Cells(i, 4).Value
For x = ws.Cells(Rows.Count, 4).End(xlUp).Row To 1 Step -1
Set rng = ws.Cells(x, 4)
If InStr(1, rng.Value, lookupvalue) > 0 Then
rng.Delete 'this only deletes the cell
'You may want this instead
'rng.entirerow.delete
End If
Next x
Next i
End Sub
I would like to propose an alternative way to handle this using a For Each Loop and the Find Method of the Range object.
Sub DeleteRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lookup_rng As Range
Dim lookupvalue As String
Dim search_rng As Range
Dim rng As Range
Dim match_rng As Range
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
Set lookup_rng = Application.Intersect(ws2.Range("D:D"), ws.UsedRange)
Set search_rng = Application.Intersect(ws.Range("D:D"), ws2.UsedRange)
For Each rng In lookup_rng.Cells
lookupvalue = rng.Value
With search_rng
Set match_rng = .Find(lookupvalue, LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlPrevious)
Do Until NoMoreMatches(match_rng)
match_rng.Delete 'Or match_rng.EntireRow.Delete if you want to delete the entire row.
Set match_rng = .FindPrevious
Loop
End With
Next
End Sub
Private Function NoMoreMatches(MatchRng As Range) As Boolean
NoMoreMatches = MatchRng Is Nothing
End Function
This approach is a little bit more wasteful then that of Scott Craner since the Find method always starts from the end of the range. However, I think it has the advantage that it is easier to read, i.e. that the code more directly shows what it is supposed to do.
Moreover, using this version you could extract the loops into a separate Sub you can use for arbitrary lookup and search ranges.
I basically need to copy rows from one sheet to another. The rows which I need to copy are on sheet 2 , columns A to N and I need to copy the rows that has the unique value in column N.
Column N will just be =M1 or =M2 depending on which row has data on it.
Hence I will use a worksheet calculate event to try capture this.
The tricky part is that each time new values exist in say the last row on sheet 2 and then N gets filled form M. I don't want the previously copied rows to be copied. It may also be the case that the entire contents of the rows change places or that one of the rows disappears and the other row will fill its gap on sheet 2. So I need to avoid the calculate event recognizing this from the =M line. i.e if it has already been copied but gets recalcuated - -I don't need it to be copied again.
I guess one way to do this would be toi lookup if the N column value exists in the N column value on sheet 1. Because if that row disappears then it will be on the sheet 1. it will because I have other formulas putting it there.
My starting point for dong this is the code below and I have this set in the worksheet code of sheet 1
Private Sub Worksheet_Calculate()
Dim i As Long
Dim lr1 As Long, lr2 As Long
Dim Delta As String
Dim wks1 As Worksheet, wks2 As Worksheet
Set wks1 = ActiveSheet
Set wks2 = Worksheets("Sheet2") 'change to suit
lr1 = wks1.Cells(Rows.Count, "N").End(xlUp).Row
For i = 2 To lr1
lr2 = wks2.Cells(Rows.Count, "A").End(xlUp).Row + 1
wks1.Cells(i, "N").EntireRow.Copy Destination:=wks2.Cells(lr2, "A")
Next i
End Sub
I also have this working which I would need to incorporate into that worksheet calcualte
Sub updt()
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, rng As Range
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh1.Range("A2:A" & lr)
For Each c In rng
If WorksheetFunction.CountIf(sh2.Range("A:A"), c.Value) = 0 Then
sh2.Range("A" & sh2.Cells(Rows.Count, 1).End(xlUp).Row)(2) = c.Value
End If
Next
End Sub
The fastest method is pretty sure to copy all wanted rows an then call the remove dublicates function which is almost instantanios. You can simply set your unique col as indicator