Sub FIXPAY()
Dim LastCol As Long, LastRow As Long, s2 As Worksheet
Set s2 = Sheets("Analysis")
s2.Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Copy
s2.Range("A" & Rows.Count).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
'*Copy the table header from 1st table and paste it to the second empty row.*
Range("A3:C3").Select
Range(Selection, Selection.End(xlDown)).Copy
s2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'*Copy from A3:C3 to the last filled row and paste it to the row right below
the heading.*
s2.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).FormulaR1C1 = _
"=INDIRECT(""'""&RC1&""'!""&ADDRESS(ROW(R73C[-2]),COLUMN(R73C[-2])))"
'*Put the above formula in the D Column right below the heading*
The problem lies here.How can I replace the below line with dynamic range such that it will auto-fill the data in the D Column
s2.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).FormulaR1C1 = _
"=INDIRECT(""'""&RC1&""'!""&ADDRESS(ROW(R73C[-2]),COLUMN(R73C[-2])))"
s2.Range("D15").AutoFill destination:=Range("D15:D" & Range("A15").End(xlDown).Row)
LastCol = Cells(14, Columns.Count).End(xlToLeft).Column
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("D15", Cells(LastRow, LastCol)).FormulaR1C1 = Range("D15").FormulaR1C1
End Sub
Can someone please help me making the code fully dynamic? Please note that I have referenced as row 15 here because my heading of the second table is in row 14 and hence the formula from D15 is to be copied to the last filled row and last filled column.
Related
So, I'm very new to VBA and I am having a difficult time finding answers to what I believe should be a fairly straightforward question.
I have a workbook that has 2 sheets, which we will call Sheet1 and Sheet2.
I want to copy data from columns B, D and E on Sheet1 to the first available row in columns A, B and C on Sheet 2, with the following changes:
Sheet1 Sheet2
Col E Col A
Col D Col B
Col B Col C
But I only want the data to be copied if the cell value of each row in Sheet1 Column I is "Y".
I don't have any code for this yet.
UPDATE:
After taking advice from a response, I ran a Macro record and got this:
Sub VBlk()
'
' VBlk Macro
' V Block Copy
'
'
Range("B2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("C3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("B3").Select
Sheets("Sheet1").Select
Range("D2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet1").Select
Range("E2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Try the code below (Hope it helps) :
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("sheet1")
Set ws2 = Sheets("sheet2")
'get the Last non empty row in sheet1 based on Column B
lastrow1 = ws1.Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To lastrow1
'get the Last non empty row in sheet2 based on Column A
lastrow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
If ws1.Range("I" & i).Value = "Y" Then
ws2.Range("A" & lastrow2 + 1).Value = ws1.Range("E" & i)
ws2.Range("B" & lastrow2 + 1).Value = ws1.Range("D" & i)
ws2.Range("C" & lastrow2 + 1).Value = ws1.Range("B" & i)
End If
Next i
End Sub
I am trying to filter a data set in tab "Expiring Contracts", filtered on column B (this data set can increase or decrease based at any point). The different filters come from tab "Inputs" which can change overtime (increase or decrease). I am trying to paste the results of the filter to separate tabs that are named exactly like the list, BUT I want to paste the values on the next available (blank) cell. This is what I have now:
Sub ParseList2()
Dim uwname As String
Dim lastrowUW As Long
Dim lastrow As Long
Dim N As Range
lastrowUW = Sheets("Inputs").Cells(Rows.Count, "H").End(xlUp).Row
For Each N In Sheets("Inputs").Range("H2:H" & lastrowUW).Cells
uwname = N.Text
Sheets("Expiring Contracts").Range("$A:$AA").AutoFilter Field:=2,
Criteria1:=N
lastrow = Columns(2).Find("*", SearchDirection:=xlPrevious).Row
Range("A2:AA" & lastrow).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets(uwname).Select
lastrow = Columns(2).Find("*", SearchDirection:=xlPrevious).Row + 1
Range("A" & lastrow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next N
Sheets("Expiring Contracts").AutoFilterMode = False
End Sub
This worked thanks to some comments below!
Sub ParseList2()
Dim uwname As String
Dim lastrowUW As Long
Dim lastrow As Long
Dim N As Range
Dim rng As Range
lastrowUW = Sheets("Inputs").Cells(Rows.Count, "H").End(xlUp).Row
For Each N In Sheets("Inputs").Range("H2:H22").Cells
uwname = N.Value
Sheets("Expiring Contracts").Range("$A:$AA").AutoFilter Field:=2,
Criteria1:=uwname
'lastrow = Columns(2).Find("*", SearchDirection:=xlPrevious).Row + 1
Range("A2:AA99999").SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets(uwname).Select
lastrow = Columns(2).Find("*", SearchDirection:=xlPrevious).Row + 1
Range("A" & lastrow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Sheets("Expiring Contracts").Select
Sheets("Expiring Contracts").AutoFilterMode = False
Range("A1").Select
Next N
Sheets("Expiring Contracts").Select
Sheets("Expiring Contracts").AutoFilterMode = False
Range("A1").Select
End Sub
What you are attempting to do using VBA can very easily be accomplished using PivotTables and Slicers. Turn your source data into an Excel Table, make a PivotTable out of it, put the PivotTable in the Inputs tab, set up a Slicer on the field you want to filter on, put the other fields of interest in the PivotTable as row fields, and you're done. No code necessary. Let the application do the work for you.
I have seen some examples but they have been using .Select and .Activate. I am trying to learn how to not use those anymore because everyone says you should try to stay away from them.
I want to take a row, then copy it to the first blank row on the other sheet. I was close but it just isn't working.
UsdRws = Range("A" & Rows.Count).End(xlUp).Row
With Sheets("Totals by Department")
.Range("A1:Z" & UsdRws).autofilter Field:=1, Criteria1:="1450"
.Range("A2:Z" & UsdRws).SpecialCells(xlCellTypeVisible).EntireRow.COPY
End With
Set NextRow = Range("A" & Sheets(2).UsedRange.Rows.Count + 1)
Sheets(2).NextRow.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Set NextRow = Nothing
The first part copies perfectly, I really just need help pasting it over on the other sheet. I will also take other recommendations for cleaning the code up. Like I said I am trying to learn to write better. The second part is messy because I have been adding and editing it but now I am lost.
Your "NextRow" object is a Range object, but you are calling it as if it were a method or property of Sheets(2).
Try removing the Sheets(2). and just start with Next Row.
Set NextRow = Sheets(2).Range("A" & Sheets(2).UsedRange.Rows.Count + 1)
NextRow.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
' UsdRws is equal the last used row on whichever sheet is active at the moment that this code runs
UsdRws = Range("A" & Rows.Count).End(xlUp).Row
' this code properly references ranges on a specific worksheet, regardless of which worksheet is active
With Sheets("Totals by Department")
.Range("A1:Z" & UsdRws).autofilter Field:=1, Criteria1:="1450"
.Range("A2:Z" & UsdRws).SpecialCells(xlCellTypeVisible).EntireRow.COPY
End With
' NextRow is reference to a cell on whichever sheet is active at the moment that this code runs
' but the row referenced is same as the first emply cell on Sheets(2)
Set NextRow = Range("A" & Sheets(2).UsedRange.Rows.Count + 1)
' NextRow is already a range .... so it should be NextRow.PasteSpecial ......
Sheets(2).NextRow.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Set NextRow = Nothing
this may be what you want
With Sheets("Totals by Department")
UsdRws = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:Z" & UsdRws).autofilter Field:=1, Criteria1:="1450"
.Range("A2:Z" & UsdRws).SpecialCells(xlCellTypeVisible).EntireRow.COPY
End With
Set NextRow = Sheets(2).Range("A" & Sheets(2).UsedRange.Rows.Count + 1)
NextRow.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Set NextRow = Nothing
I'm having trouble copying specific Rows with vba.
Here my Code:
Dim color1 As Integer
Dim color2 As Integer
Dim lines As Integer
Workbooks.Open Filename:="D:\01 January.xlsm", _
UpdateLinks:=0
lines = WorksheetFunction.CountA(Range("U:U")) - 1
Dim i As Integer
For i = 6 To lines + 6
color1 = Cells(i, 21).Value
color2 = Cells(i, 22).Value
If IsNumeric(Cells(i, 21)) Then
Select Case color1 & color2
Case Evaluate("=White") & Evaluate("=Blue")
Rows(i & ":" & i).Select
Case Evaluate("=Yellow") & Evaluate("=Yellow")
Rows(i & ":" & i).Select
Case Evaluate("=Yellow") & Evaluate("=Green")
Rows(i & ":" & i).Select
End Select
End If
Next i
Selection.Copy
Windows("Test.xlsm").Activate
Rows("11:11").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
So as you might see, I am trying to select Rows, that meet the criteria in the January.xlsm and paste them afterwards into the test.xlsm
At the moment it only pastes the last selected row and not all of them.
I'm pretty new to vba, so I would really need your help here. What I got in my mind, is to put all the needed rows into an array and then copy it into the other workbook. But no idea if thats good or just rubish and if that would work, I can't find a solution...
Thanks for all your help!
The reason it only pastes the last row is because you're looping through selecting the individual rows but not doing anything with them. See amended code.
I've removed the redundant selections in the case statement and provided a range/union combo to create your custom range to ensure you're only pasting to the worksheet once.
Dim color1 As Integer
Dim color2 As Integer
Dim lines As Integer
Workbooks.Open Filename:="D:\01 January.xlsm", _
UpdateLinks:=0
lines = WorksheetFunction.CountA(Range("U:U")) - 1
Dim i As Integer
Dim rngUnion As Range
Dim booCopy As Boolean
For i = 6 To lines + 6
booCopy = True
color1 = Cells(i, 21).Value
color2 = Cells(i, 22).Value
If IsNumeric(Cells(i, 21)) Then
Select Case color1 & color2
Case Evaluate("=White") & Evaluate("=Blue")
Case Evaluate("=Yellow") & Evaluate("=Yellow")
Case Evaluate("=Yellow") & Evaluate("=Green")
Case Else
booCopy = False
End Select
End If
If booCopy = True Then
If rngUnion Is Nothing Then
Set rngUnion = Rows(i & ":" & i)
Else
Set rngUnion = Union(rngUnion, Rows(i & ":" & i))
End If
End If
Next i
If Not rngUnion Is Nothing Then
rngUnion.Copy
Windows("Test.xlsm").Activate
With Rows("11:11")
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
End If
End Sub
The reason this only pastes the last selected row is because you are not copying and pasting within the loop. If you move the Selection.Copy/Paste within the loop the code should work. A better way to do this would be to avoid copying and pasting entirely and directly set the values of the rows. See code below:
Dim i As Integer
For i = 6 To lines + 6
color1 = Cells(i, 21).Value
color2 = Cells(i, 22).Value
If IsNumeric(Cells(i, 21)) Then
Select Case color1 & color2
Case Evaluate("=White") & Evaluate("=Blue"):
Workbooks("Test").Sheets("Sheet1").Rows(i).Value = _
Workbooks("01 January").Sheets("Sheet1").Rows(i).Value
...
End Select
End If
Next i
You can just update the sheet or workbook names as necessary but this method is substantially faster than copying and pasting.
should you have a large number of rows to be copied and paste it's safer not to rely neither on Union() nor Address() methods and switch to a "helper" column where to first mark the row for copying and then copy and paste in one shot. This is also much faster then the two methods above
you can also take advantage of SpecialCells() method to filter "numeric" cells only:
Dim lines As Long
Dim cell As Range
Workbooks.Open Filename:="D:\01 January.xlsm", UpdateLinks:=0
lines = WorksheetFunction.CountA(Range("U:U")) - 1
With Range(Cells(6, "U"), Cells(lines + 6, "U")) '<--| reference your relevant range in column "U"
For Each cell In .SpecialCells(xlCellTypeConstants, xlNumbers) '<--| loop through "numeric" cells only
Select Case cell.Value & cell.Offset(, 1).Value
Case Evaluate("=White") & Evaluate("=Blue"), Evaluate("=Yellow") & Evaluate("=Yellow"), Evaluate("=Yellow") & Evaluate("=Green")
cell.Offset(, 2).Value = 1 '<--| mark row for copying&pasting
End Select
Next
With .Offset(, 2) '<-- consider column "W" cells corresponding to referenced cells
If WorksheetFunction.CountA(.Cells) > 0 Then '<--| if there's at least one row marked for copy&paste
.SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow.Copy '<--| copy all marked rows
With Workbooks("Test.xlsm").ActiveSheet.Rows("11:11") '<--| reference target range
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False '<--| clear clipboard
End If
.ClearContents '<--| clear "helper" column
End With
End With
I am working on an excel sheet and need to move the same range over and over again to the column "P" + 2
So the next range would be "C15:G15" to "P14". I'm looking for a slimmer solution than to repeat this code and change the ranges for hundreds of times..
ActiveWindow.SmallScroll Down:=-3
Range("C13:G13").Copy
Application.CutCopyMode = False
Selection.Copy
Range("P12").Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
This quick snippet should walk down every second row in column C starting at row 13 till the last populated cell in column C.
Sub move_CG_to_PT()
Dim rw As Long
With Worksheets("Sheet4") '<~~set this worksheet reference properly!
For rw = 13 To .Cells(.Rows.Count, "C").End(xlUp).Row Step 2
.Cells(rw - 1, "P").Resize(1, 5) = _
.Cells(rw, "C").Resize(1, 5).Value
Next rw
End With
End Sub
This only transfers the values. If the formatting and/or theme is critical then those could be adjusted for with the following.
Sub move_CG_to_PT_w_Formatting()
Dim rw As Long
With Worksheets("Sheet4") '<~~set this worksheet reference properly!
For rw = 13 To .Cells(.Rows.Count, "C").End(xlUp).Row Step 2
.Cells(rw, "C").Resize(1, 5).Copy _
Destination:=.Cells(rw - 1, "P")
Next rw
End With
End Sub