Excel VBA copying range within filtered data and appending to end of table on another worksheet - vba

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

Related

Excel VBA: If statement to copy/paste into a new worksheet then delete rows of what was copied

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

Convert Excel formula into VBA Macro

I have the following formula in an excel worksheet that I want to make a Macro:
IF(OR(AA2=2,AA2=3,AA2=4),"00",IF(AA2=5,"0"&LEFT(Z2,1),IF(AA2=6,LEFT(Z2,2))))
I want to establish this formula for a certain range based on another column. I have multiple formulas written already that work to do this such as:
Range("B3:B" & Cells(Rows.Count, "M").End(xlUp).Row).Value = "=B2+1"
Basically I want to make the If/Or statement above work in VBA with the desired range.
Any help would be appreciated!
Just setup your function, turn on the Macro Recorder, click on the cell that contains your function, hit F2 and hit Enter. If you want to setup dynamic start and end rows, or columns, you can use the methodologies below.
Sub DynamicRange()
'Best used when only your target data is on the worksheet
'Refresh UsedRange (get rid of "Ghost" cells)
Worksheets("Sheet1").UsedRange
'Select UsedRange
Worksheets("Sheet1").UsedRange.Select
End Sub
OR
Sub DynamicRange()
'Best used when first column has value on last row and first row has a value in the last column
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set sht = Worksheets("Sheet1")
Set StartCell = Range("D9")
'Find Last Row and Column
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column
'Select Range
sht.Range(StartCell, sht.Cells(LastRow, LastColumn)).Select
End Sub
OR
Sub DynamicRange()
'Best used when you want to include all data stored on the spreadsheet
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set sht = Worksheets("Sheet1")
Set StartCell = Range("D9")
'Refresh UsedRange
Worksheets("Sheet1").UsedRange
'Find Last Row and Column
LastRow = StartCell.SpecialCells(xlCellTypeLastCell).Row
LastColumn = StartCell.SpecialCells(xlCellTypeLastCell).Column
'Select Range
sht.Range(StartCell, sht.Cells(LastRow, LastColumn)).Select
End Sub
OR
Sub DynamicRange()
'Best used when your data does not have any entirely blank rows or columns
Dim sht As Worksheet
Dim StartCell As Range
Set sht = Worksheets("Sheet1")
Set StartCell = Range("D9")
'Select Range
StartCell.CurrentRegion.Select
End Sub
OR
Sub DynamicRange()
'Best used when column length is static
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set sht = Worksheets("Sheet1")
Set StartCell = Range("D9")
'Refresh UsedRange
Worksheets("Sheet1").UsedRange
'Find Last Row
LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Select Range
sht.Range("D9:M" & LastRow).Select
End Sub
You will have a dynamic range from Excel when the formula is entered via VBA as such:
Range( Cells(2,"AB"), Cells (colMVal, "AB")).Formula = "=IF(OR(AA2=2,AA2=3,AA2=4),""00"",IF(AA2=5,""0""&LEFT(Z2,1),IF(AA2=6,LEFT(Z2,2))))"
Note that the formula is entered into row 2 all the way down to the column M value to dictate the final row (colMVal). Also note the double quotes WITHIN the formula.
If anything is required to be FIXED, rather than dynamic, you would use "$", such that:
Range( Cells(2,"AB"), Cells (colMVal, "AB")).Formula = "=IF(OR(AA$2=2,AA$2=3,AA$2=4),""00"",IF(AA$2=5,""0""&LEFT(Z$2,1),IF(AA$2=6,LEFT(Z$2,2))))"
Where I have locked that ALL references verify that the row is 2, hence AA$2. As Excel fills the formula into each row of the desired range, it will dynamically assign the correct row.

How to copy rolling 3 values to another sheet using VBA

I have a pivot table as in Image. I would like to copy and paste the rolling last 3 months values to another sheet. That is i need to copy NOV,DEC,JAN values to another sheet.That is Cell value A17:C17, A18:C18 and A7:C7.
For next month it must automatically copy DEC,JAN,FEB values. I used the below but i cant get the logic. I need to copy twice. First for Cells A,B,C and for cell A,D,E. How to change the code Help me
Sub Data()
Dim sws, dws As Worksheet
Dim lr1 As Long
Dim rng1 As Range
Set sws = Sheets("AVG")
Set dws = Sheets("Data")
lr1 = sws.Cells(Rows.Count, "B").End(xlUp).Row
Set rng1 = Union(sws.Range("E" & lr1).Offset(-2, -4).Resize(3), sws.Range("E" & lr1).Offset(-2, -1).Resize(3), sws.Range("E" & lr1).Offset(-2).Resize(3))
rng1.Copy dws.Range("A28")
Sheets("AVG").Range("A" & Rows.Count).End(xlUp).Offset(-2, -2).Resize(3, 3).Copy Sheets("Data").Range("A33")
End Sub

if else statement at copying and pasting a cell value

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.

VBA: copy whole column content starting for a specific and and the data below it

the thing is I want to copy a certain column but I want to only copy data on a specific cell and get the data below it.
Let say for example, I want to copy Cell C5 and below, this will disregard C1 to C4. Is this possible?
Further to my comments below your question, here is one way. This will work in all scenarios. Whether you have blank cells or not...
Option Explicit
Sub CopyCells()
Dim ws As Worksheet
Dim rng As Range
Dim sRow As Long, lRow As Long
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
sRow = 5 '<~~ Starting row
With ws
'~~> Find last row in Col C
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
'~~> If the last row < Start Row
If lRow < sRow Then
MsgBox "Start Row cannot be greater then last row"
Else
'~~> Create your range
Set rng = .Range("C" & sRow & ":C" & lRow)
'~~> Copy
rng.Copy
'
' Do what you want with copied data
'
End If
End With
End Sub
Sheet1.Columns(3).Resize(Sheet1.Columns(3).Rows.Count - 4).Offset(4).Select
This will select entire C column but first 4 cells. It simply take column 3, resize it to subtract first 4 cells and offset the starting cell 4 cell below and select that range.
If your range is defined then code could be more optimized.
EDIT for sample code:
Sub copyCells()
Dim sht As Worksheet
Dim rngStart As Range
Dim rng As Range
Set sht = Sheet1
Set rngStart = sht.Cells(5, 3) ' this is C5
rngStart.Select
Set rng = rngStart.Resize(rngStart.End(xlDown).Row - rngStart.Row + 1)
rng.Copy Sheet2.Cells(1, 1) ' copy where you need
End Sub
This will copy a entire column (with data) from selection, just paste it wherever you want.
Sub CopyColumnFromSelected()
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
End Sub
Or (Ctrl + Shift + down arrow) <--- from your desired cell and Ctrl+C ;)