I'm trying to copy a table from sheet 1, defined by the area D21:O21, until the end – (minus) the last 4 lines.
I have a problem pasting results. In sheet 2 I have a table that feeds pivot charts. After I delete previous filled rows (with values) and paste new ones (new values) the table extends further than it is supposed to. It adds blank cells downstream as if the copied sheet 1 had more rows with values.
For example: Imagine that my table (in sheet 1) has 600 rows with values. If I paste to the table (in sheet 2) it extends further than 600 rows (approx. 10000). Instead of adding multiple empty lines I want 600 except last 4 lines = from top to 596 rows.
Sub Prime()
Dim Last_Row1 As Long, Last_Row2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Enter DATA here")
Set ws2 = Sheets("DATA")
Application.ScreenUpdating = False
Last_Row1 = ws1.Range("C" & Rows.Count).End(xlUp).Row ' Determine the lastrow of the data to copy
Last_Row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row ' Determine the next empty row in order to paste the data
ws1.Range("D21:O21" & Last_Row1).Copy ws2.Range("A" & Last_Row2)
Application.ScreenUpdating = True
End Sub
Try this:
Sub Prime()
Dim Last_Row1 As Long, Last_Row2 As Long, table As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Enter DATA here")
Set ws2 = Sheets("DATA")
Set table = ws1.Range("D21:O28") // I arbitrarily set this to 8 rows
Application.ScreenUpdating = False
Last_Row1 = ws1.Range("C" & Rows.Count).End(xlUp).Row ' Determine the lastrow of the data to copy
Last_Row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row ' Determine the next empty row in order to paste the data
table.Resize(table.Rows.Count - 4, table.Columns.Count).Copy ws2.Range("A" & Last_Row2)
Application.ScreenUpdating = True
End Sub
Sub Prime()
Dim Last_Row1 As Long, Last_Row2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Enter DATA here")
Set ws2 = Sheets("DATA")
Application.ScreenUpdating = False
Last_Row1 = ws1.Range("C" & Rows.Count).End(xlUp).Row ' Determine the lastrow of the data to copy
Last_Row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row ' Determine the next empty row in order to paste the data
ws1.Range("D21:O" & Last_Row1-4).Copy ws2.Range("A" & Last_Row2)
Application.ScreenUpdating = True
End Sub
You can use Offset function to exclude the last 4 rows.
Last_Row1 = ws1.Range("C" & Rows.Count).End(xlUp).offset(-4,0).Row
When you copy the range, you should delete row indicator "21" behind column "O", otherwise, the code would not select till the last row. Like following:
ws1.Range("D21:O" & Last_Row1).Copy ws2.Range("A" & Last_Row2)
Related
i would like to compare two columns in two different sheets like column A in sheet 1 start from row 2 till the last row and columns C start from row 2 till the last row. If row in column A is greater than the same row in column C a message box " the value is greater" appear and clear the greater value in column A. Thanks an advance for your support
This should get you started
Sub compare()
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Set sheet1 = ThisWorkbook.Sheets("Sheet1")
Set sheet2 = ThisWorkbook.Sheets("Sheet2")
Dim lastrow As Integer
lastrow = sheet1.Range("A2").End(xlDown).Row
Dim i As Integer
For i = 2 To lastrow
If sheet1.Range("A" & i).Value > sheet2.Range("A" & i).Value Then
MsgBox ("the value is greater")
sheet1.Range("A" & i).Value = ""
End If
Next i
End Sub
Delete Greater Than
Option Explicit
Sub deleteGreaterThan()
Dim wb As Workbook
Dim src As Worksheet
Dim dst As Worksheet
Dim LastRow As Long
Dim i As Long
Set wb = ThisWorkbook
Set dst = wb.Worksheets("Sheet1")
Set src = wb.Worksheets("Sheet2")
LastRow = dst.Cells(dst.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
If dst.Cells(i, "A").Value > src.Cells(i, "C").Value Then
MsgBox "The value in cell '" & dst.Cells(i, "A").Address(0, 0) _
& "' is greater."
dst.Cells(i, "A").Value = ""
End If
Next i
End Sub
I had previous question on how to find the last row of data for a formula in Column A based on data in Column C. And ya'll helped me figured that portion out!
Now I'm taking it a step further, and looping through more worksheets.
The data in Column C is Copying/Pasting correctly to the next available row.
However, the formula is pasting over the first set of data in Column A, versus finding the last row.
Better yet.. is there a way to make this formula a 1 liner?? I can't seem to get that to work either.
`Dim Mkts As Worksheet
Dim ws As Worksheet
'Destination Worksheet
Set Mkts = Workbooks("Nielsen SC Template.xlsm").Worksheets("Markets")
'Copy 4Wk Data
Workbooks.Open "C:\Users\cday\OneDrive - udfinc.com\Nielsen Scorecard\4Wk Data.xlsx"
Dim Wb4 As Workbook
Set Wb4 = Workbooks("4Wk Data.xlsx")
For Each ws In Wb4.Worksheets
With ws
If .Index <> 1 Then
'Find last used row in the copy range based on data in Column A
Dim CopyLastRow4 As Long
CopyLastRow4 = .Cells(.Rows.Count, 1).End(xlUp).Row
'Find first blank row in the destination range based on data in Column C, Offset 1 Row
Dim DestLastRowC As Long
DestLastRowC = Mkts.Cells(Mkts.Rows.Count, "C").End(xlUp).Offset(1).Row
'Find last used row in the destination range based on data in Column C
Dim LastRowColumnC As Long
LastRowColumnC = .Range("C" & .Rows.Count).End(xlUp).Row
If .Index = 2 Then
'Copy and Paste Data into C3
.Range("A4:V" & CopyLastRow4).Copy Mkts.Range("C" & DestLastRowC)
'Add Dates to Column A
Dim FR As Range 'first row
Dim LR As Range 'last row
Set FR = Mkts.Range("A3")
Set LR = Mkts.Range("A" & LastRowColumnC - 1)
Range(FR, LR).Formula = "=Mid('[4Wk Data.xlsx]Report1'!$A$1, 9, 28)"
'Add Markets to Column B
Set FR = Mkts.Range("B3")
Set LR = Mkts.Range("B" & LastRowColumnC - 1)
Range(FR, LR).Formula = "=Mid('[4Wk Data.xlsx]Report1'!$A$1, 48, 13)"
End If
If .Index = 3 Then
'Copy and Paste Data into C3
.Range("A4:V" & CopyLastRow4).Copy Mkts.Range("C" & DestLastRowC)
**'Add Dates to Column A
Set FR = Mkts.Range("A" & DestLastRowC)
Set LR = Mkts.Range("A" & LastRowColumnC)
Range(FR, LR).Formula = "=Mid('[4Wk Data.xlsx]Report2'!$A$1, 9, 28)"
'Add Markets to Column B
'Set FR = Mkts.Range("B" & DestLastRowC)
'Set LR = Mkts.Range("B" & LastRowColumnC)
'Range(FR, LR).Formula = "=Mid('[4Wk Data.xlsx]Report2'!$A$1, 48, 15)"**
End If
End If
End With
Next ws
Try something like this:
Sub Test()
Dim Mkts As Worksheet, ValA1
Dim ws As Worksheet, Wb4 As Workbook, rngCopy As Range, rngDest As Range
'Destination Worksheet
Set Mkts = Workbooks("Nielsen SC Template.xlsm").Worksheets("Markets") 'ThisWorkbook ?
'Copy 4Wk Data
Set Wb4 = Workbooks.Open("C:\Users\cday\OneDrive - udfinc.com\Nielsen Scorecard\4Wk Data.xlsx")
For Each ws In Wb4.Worksheets
With ws
If .Index = 2 Or .Index = 3 Then
'range of data to be copied from ws: A4 to V[last row in colA]
Set rngCopy = .Range("A4:V" & .Cells(.Rows.Count, 1).End(xlUp).Row)
'destination for pasting in ColC
Set rngDest = Mkts.Cells(Mkts.Rows.Count, "C").End(xlUp).Offset(1)
rngCopy.Copy rngDest 'copy the data
'grab the value from A1 on Report1
ValA1 = .Range("A1").Value '<<<<<<
'fill a range starting from rngDest two columns to the
' left and the same size (# of rows) as the copied range
' using part of the value from A1
rngDest.Offset(0, -2).Resize(rngCopy.Rows.Count).Value = Mid(ValA1, 9, 28) 'ColA
'similar process for a column one to the left from rngDest
rngDest.Offset(0, -1).Resize(rngCopy.Rows.Count).Value = Mid(ValA1, 48, 13) 'ColB
End If
End With
Next ws
End Sub
I wanted to copy data from one sheet to another. The selection part is according to date and specific value of column.
enter image description here
I tried this code from internet. So the basic logic is if 2 condition are met then copy the row. However its not working.
It actually working first when only one condition are written, when the second one written, the VBA did not do anything
Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Clean_Sheet")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Daily_Report")
For i = 2 To ws1.Range("P65536").End(xlUp).Row
If ws1.Cells(i, 1) = "DOWNY S.FRESH 900ML" and ws2.Range ("C2") = ws1.Cells(i,3) Then
ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
End If
Next i
End Sub
the ws2.Range("C2") are selected date written in cell C2 in the sheet.
The result are the row copied based on this 2 criteria
This works assuming both your data in worksheet 1 are really dates and the filter in C2 is a date also:
Option Explicit
Sub CopyRowsAcross()
Dim LastRow As Long, lrow As Long
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Clean_Sheet")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Daily_Report")
Dim DateFilter As Date
With ws2
DateFilter = .Cells(2, 3)
lrow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
With ws1
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A1:C" & LastRow).AutoFilter Field:=1, Criteria1:="DOWNY S.FRESH 900ML"
.Range("A1:C" & LastRow).AutoFilter Field:=3, Criteria1:=Format(DateFilter, "dd-Mmm-yy")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If LastRow > 1 Then
.Range("A2:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(lrow, 1)
End If
.AutoFilterMode = False
End With
End Sub
Instead of looping (Time consuming) you could just filter the data you need and copy it all a t once.
I have made a macro that copies two dynamic table columns from one worksheet to another. On the Second worksheet I want to subtract those two columns and paste the result on a separate column/vector. All of this needs to be dynamic since I plan on running the macro once a day.
The closest I have come is the following code:
Sub Makro2()
Dim ws_3 As Worksheet
Set ws_3 = ThisWorkbook.Worksheets(2)
Application.CutCopyMode = False
ws_3.Range("E3:E400").FormulaR1C1 = "=RC[-2]-RC[-1]"
End Sub
So all I need in reality is for E3:E400 to be dynamic since the range of the other two columns change every day.
PS. Rather new at VBA.
This is just basic, ensure you declare your variable.
Dim lRow As Long
lRow = Range("D" & Rows.Count).End(xlUp).Row
Range("E3:E" & lRow).FormulaR1C1 =
You could try:
Option Explicit
Sub test()
Dim wsSource As Worksheet, wsDestination As Worksheet
Dim LastRow1 As Long, LastRow2 As Long, rng1 As Range, rng2 As Range, LastColumn As Long
With ThisWorkbook
Set wsSource = .Worksheets("Sheet1") '<- Data appears here
Set wsDestination = .Worksheets("Sheet2") '<- Data will be copy here
End With
With wsSource
'Let's say the two columns we want to copy is column A & B. Find Last row of A & B
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
LastRow2 = .Cells(.Rows.Count, "B").End(xlUp).Row
'Create the ranges you want to copy
Set rng1 = .Range("A1:A" & LastRow1)
Set rng2 = .Range("B1:B" & LastRow2)
End With
With wsDestination
'Paste column after the last column of row 1. Find last column row 1
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
rng1.Copy
.Cells(1, LastColumn + 1).PasteSpecial xlPasteValues
rng2.Copy
.Cells(1, LastColumn + 2).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
End Sub
I want to copy the values from A and B columns of the orders tab of the workbook and paste those values to the Duplicate warning settings tab after the last active row.
Public Sub My_Copy_Orders()
Dim Last_Row As Long
Sheets("Duplicate warning Settings").Select
Last_Row = Range("A1").End(xlDown).Offset(1).Row
Sheets("Orders").Columns("A:B").Copy Destination:=Sheets("Duplicate warning Settings").Range("A" & Last_Row)
End Sub
It gives me an error
You're copying entire columns A & B (all 1,048,576 rows by two columns). Your destination is correctly using only the top-left corner as a reference point but since you are below the first row, you no longer have 1,048,576 rows worth of empty cells below the destination. Essentially you're trying to paste empty cells below the bottom of the worksheet.
Simply limit the source of the copy to the worksheet's usedrange.
with Sheets("Orders")
intersect(.usedrange, .Columns("A:B")).Copy _
Destination:=Sheets("Duplicate warning Settings").Range("A" & Last_Row)
end with
Try below sub
Public Sub My_Copy_Orders()
Dim Last_Row As Range
Dim sht1, sht2 As Worksheet
Dim aRow, bRow As Long
Set sht1 = Sheets("Duplicate warning Settings")
Set sht2 = Sheets("Orders")
Set Last_Row = sht1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
aRow = sht2.Range("A1").End(xlDown).Row
bRow = sht2.Range("B1").End(xlDown).Row
If aRow > bRow Then
sht2.Range("A1:B" & aRow).Copy Last_Row
Else
sht2.Range("A1:B" & bRow).Copy Last_Row
End If
End Sub
Basic code using variables.
Dim wsSrc As Worksheet, wsDest As Worksheet, scrlRow As Long
Set wsSrc = ThisWorkbook.Sheets("Orders")
Set wsDest = ThisWorkbook.Sheets("Duplicate warning Settings")
srclRow = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row
Dim cpyRng As Range
Set cpyRng = Range("A1:B" & srclRow)
cpyRng.Copy wsDest.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)