I'm trying to copy and paste a variable range from "Sheet 1" into "Sheet 2" and offset the cell that I'm pasting into Sheet 2 by one row. I'm doing this so I can add more data into Sheet 2 without overwriting data already pasted.
I created the desired copying ranges for sheet 1:
Dim rw As Range
Set rw = Sheets("Sheet 1").Range(Range("A4"), Range("A4").End(xlDown))
Dim clm As Range
Set clm = Sheets("Sheet 1").Range(Range("A4"), Range("A4").End(xlToRight))
Now I want to paste the range into Column A from Sheet 2 but under the last row used.
I got the following code to work to paste into cell A3 of Sheet 2:
Sheets("Sheet 1").Range(rw, clm).Copy Sheets("Sheet 2").Range("A3")
But I don't know how to offset by 1 row under every time.
Any help would be appreciated!
Copy Data From Table
A Quick Fix
Sub CopyData()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
Dim srg As Range
With sws.Range("A4")
Set srg = sws.Range(.End(xlDown), .End(xlToRight))
End With
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
Dim dfCell As Range
Set dfCell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
srg.Copy dfCell
End Sub
Related
I've been stuck on this task for a while, hope someone can help!
I'm working on a macro to reference data from a number of separate tabs with company-specific information into a single master sheet. Some key points:
The number of companies will change (never above 200), so I want to loop through all worksheets except a specified range
Data in the company worksheets is brought in via an API, so for the data to appear in the master sheet I need to reference specific cells in the company worksheets
Data will be stored in a single column so, say, master sheet cells A2 downwards
So basically I want code that can:
Reference cell A1 from Worksheet "Company 1" in the master sheet cell A2
Reference cell A1 from Worksheet "Company 2" in the master sheet cell A3
...
Reference cell A1 from Worksheet "Company X" in the master sheet cell AX+1
Stop
Here is what I have so far...
Dim ws As Worksheet
Dim companies As Range
Dim arr As Variant: arr = Array("Mastersheet", "Conversions", "Dates")
Worksheets("Mastersheet").Activate
Set companies = Range("A2:A200")
For Each ws In ThisWorkbook.Worksheets
If Not (IsNumeric(Application.Match(ws.Name, arr, 0))) Then
Worksheets("Daily Return").Activate
Next ws
Import Data From the Same Cell in Different Worksheets
Option Explicit
Sub ImportData()
Dim Exceptions(): Exceptions = Array("Mastersheet", "Conversions", "Dates")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Sheets("Mastersheet")
Dim dfCell As Range: Set dfCell = dws.Range("A2")
dfCell.Resize(dws.Rows.Count - dfCell.Row + 1).Clear
Dim sws As Worksheet
For Each sws In wb.Worksheets
If IsError(Application.Match(sws.Name, Exceptions, 0)) Then
dfCell.Value = sws.Range("A1").Value
'dfCell.Formula = "='" & sws.Name & "'!A1" ' !?
Set dfCell = dfCell.Offset(1)
End If
Next sws
MsgBox "Data imported.", vbInformation
End Sub
I copy data from workbook to another workbook ,copying of single contiguous selection works without problem.
But, If I copied two selections (using CTRL) , even adjacent , nothing copied to the destination workbook (with no error raised).
How to adapt the below code to make it Copy non-contiguous selection from workbook to another?
In advance, grateful for useful answer and comments.
Dim wb As Workbook: Set wb = ThisWorkbook 'Source Workbook
Dim srg As Range: Set srg = wb.ActiveSheet.Range(Selection.Address)
Dim wb1 As Workbook: Set wb1 = Workbooks.Add 'Destination Workbook
Dim drg As Range: Set drg = wb1.Sheets(1).Range("A1")
srg.Copy drg
srg.Copy
drg.PasteSpecial Paste:=xlPasteColumnWidths
Dim r As Range
For Each r In drg.Rows
r.WrapText = True
If r.RowHeight < 40 Then r.RowHeight = 40 'This line works
Next r
This answer refers to #karma
Just I need to copy columns width then copy values after it.
srg.Copy
drg.PasteSpecial Paste:=xlPasteColumnWidths
srg.Copy drg
I'm trying to create a macro that copies a certain range (CA1:CZ99) from "Sheet A" to lots of other sheets. The names of the other sheets are based on a value of column F in "Sheet B".
The code for copying the data is easy to find.
Worksheets("Sheet A").Range("CA1:CZ99").Copy Worksheets("Sheet X").Range("CA1")
But how do I loop this part over all the sheets from column F?
Copy a Range to Multiple Worksheets
Option Explicit
Sub CopyRange()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet A")
Dim srg As Range: Set srg = sws.Range("CA1:CZ99")
' Lookup
Dim lws As Worksheet: Set lws = wb.Worksheets("Sheet B")
Dim lfRow As Long: lfRow = 2
Dim llRow As Long: llRow = lws.Cells(lws.Rows.Count, "F").End(xlUp).Row
If llRow < lfRow Then Exit Sub ' no data
Dim lrg As Range: Set lrg = lws.Cells(lfRow, "F").Resize(llRow - lfRow + 1)
' Copy to Destination
Dim dws As Worksheet
Dim lCell As Range
Dim lCount As Long
For Each lCell In lrg.Cells
On Error Resume Next ' check if the worksheet exists
Set dws = wb.Worksheets(CStr(lCell.Value))
On Error GoTo 0
If Not dws Is Nothing Then ' the worksheet exists
lCount = lCount + 1
srg.Copy dws.Range("CA1")
Set dws = Nothing
'Else ' the worksheet doesn't exist
End If
Next lCell
' Inform
MsgBox "Range copied to " & lCount & " worksheets.", _
vbInformation, "CopyRange"
End Sub
Specify exactly where to get the data from as a variable, and then loop over it. Example:
Sub loopCopy()
Dim shtRng As Range
Dim c As Variant
Set shtRng = Worksheets("Sheet B").Range("F1:F5")
For Each c In shtRng
Worksheets("Sheet A").Range("CA1:CZ99").Copy Worksheets(c.Value).Range("CA1")
Next c
End Sub
This is a very basic setup. If the value from the column doesn't match a sheet, or if "Sheet A" or "Sheet B" change names, it will crash.
You might want to have the list adjust in size dynamically by finding last row, etc.
my code aims to copy the same range from multiple sheets and paste the data from each sheet into the next empty column in a Combined sheet. My code copies from each sheet correctly, but pastes into the same column and overwrites the preceding paste.
Could someone please point out my error?
Many thanks!
Sub CopyToNextCol()
Dim Sh As Worksheet
Dim NextCol As Long
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name <> "Master" And Sh.Name <> "Lists" And Sh.Name <> "Combined" Then
NextCol = Sheets("Combined").Cells(, Columns.Count).End(xlToLeft).Column + 1
Sh.Range("B2:B44").Copy Sheets("Combined").Cells(, NextCol)
End If
Next Sh
End Sub
Copy Same Ranges From Multiple Worksheets
The following example will copy the worksheet names ("I am planning to use a different column header" in the comments) in the first row and each range below it.
s - Source, d - Destination.
A Quick Fix
Option Explicit
Sub CopyToNextCol()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Worksheets("Combined")
Dim dCell As Range
Set dCell = dws.Cells(1, dws.Columns.Count).End(xlToLeft).Offset(, 1)
Dim sws As Worksheet
Dim srg As Range
For Each sws In wb.Worksheets
Select Case sws.Name
Case "Master", "Lists", "Combined"
' Skip (do nothing)
Case Else
Set srg = sws.Range("B2:B44")
dCell.Value = sws.Name
srg.Copy dCell.Offset(1)
Set dCell = dCell.Offset(, 1)
End Select
Next sws
'wb.Save
End Sub
I have 2 different excel files, stored in C:\Test:
Book1.xlsx, with Sheet1 (data in the Sheet1 is changing, not constant data-range, but always starts from A1 cell)
Book2.xlsm, with Sheet2 (empty)
Every time after opening Book2, I need data from Sheet1 of Book1 to be automatically copied into Sheet2 of Book2.
Update:
I tried the following vba code (researched online from Excel Forum)
Private Sub Workbook_Open()
Application.EnableEvents = False
Dim swb As Workbook, Lr As Long, LC As Long, sws As Worksheet
Dim dCell As Range, srg As Range, dwb As Workbook, dws As Worksheet
Set swb = Workbooks.Open("C:\Test\AAA\Book1.xlsx")
Set sws = swb.Worksheets("Sheet1")
Lr = sws.Cells(Rows.Count, 1).End(xlUp).Row
LC = sws.Cells(1, Columns.Count).End(xlToLeft).Column
Set srg = sws.Range(Cells(1, 1), Cells(Lr, LC))
Set dwb = ThisWorkbook
Set dws = dwb.Worksheets("Sheet2")
Set dCell = dws.Range("A1")
srg.Copy dCell
swb.Close SaveChanges:=False
dwb.Save
Application.EnableEvents = True
End Sub
But, the problem with this - that if I delete a few records after the 1st one from Sheet1 of Book1, then - these deleted records still appear in the Sheet2 of Book2!
I am not great in vba, it's just a part of my whole project
Sorry for these questions
Update 2:
When I have the following in Sheet1, Book1:
Then, after opening Sheet2, Book2, I see (which is correct, what I expected):
But, if I'll delete records in Sheet1, Book1 (starting from the 2nd):
Then, after opening Sheet2, Book2 I will still see those deleted from Book2 records (while I expect them to be gone):
When the destination sheet has more data than the source sheet, you will need to clear it before you copy over the data. You could do it with the Range-method ClearContents:
Set dws = dwb.Worksheets("Sheet2")
dws.Usedrange.ClearContents
Set dCell = dws.Range("A1")
srg.Copy dCell
As it seems that you are copying the data of the whole sheet, an alternative could be to remove the sheet in ThisWorkbook and copy the sheet itself:
' Delete Sheet2 (if present)
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Sheet2").Delete
Application.DisplayAlerts = True
On Error GoTo 0
' Copy Sheet from sourceWorkbook
sws.Copy after:=ThisWorkbook.Sheets(1)
ActiveSheet.Name = "Sheet2" ' Copied sheet gets the active sheet automatically.
Clear Range Below Copied Data
Private Sub Workbook_Open()
Application.EnableEvents = False
Dim swb As Workbook, sws As Worksheet, srg As Range, LR As Long, LC As Long
Dim dwb As Workbook, dws As Worksheet, dCell As Range
Set swb = Workbooks.Open("C:\Test\AAA\Book1.xlsx")
Set sws = swb.Worksheets("Sheet1")
LR = sws.Cells(sws.Rows.Count, 1).End(xlUp).Row
LC = sws.Cells(1, sws.Columns.Count).End(xlToLeft).Column
Set srg = sws.Range(sws.Cells(1, 1), sws.Cells(LR, LC))
Set dwb = ThisWorkbook
Set dws = dwb.Worksheets("Sheet2")
Set dCell = dws.Range("A1")
srg.Copy dCell
With dCell.Resize(, srg.Columns.Count)
.Resize(.Worksheet.Rows.Count - .Row - srg.Rows.Count + 1) _
.Offset(srg.Rows.Count).Clear
End With
swb.Close SaveChanges:=False
dwb.Save
Application.EnableEvents = True
End Sub