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
Related
I would like to copy a Cell from all worksheet but "Data" Worksheet on column C of "Data Worksheet". The following code is not working properly, always blank value. The value I would like to copy is placed on E16 Cell.
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Data" Then
x = x + 1
Sheets("Data").Range("B1").Offset(x) = Worksheets(ws.Name).Cells(4, 16).Value
End If
Next ws
Try it that Way, without coping every value by it's own:
Sub m()
vartemp2 = Range("A1:A2")
vartemp2 = WorksheetFunction.Transpose(vartemp2)
Dim varTemp As Variant
For Each ws In Worksheets
If ws.Name <> "Data" Then
If i = 0 Then
ReDim varTemp(1 To 1, 1 To 1)
i = 1
Else
varTemp = WorksheetFunction.Transpose(varTemp)
ReDim Preserve varTemp(1 To UBound(varTemp) + 1)
varTemp = WorksheetFunction.Transpose(varTemp)
End If
varTemp(UBound(varTemp), 1) = ws.Cells(16, 5).Value
End If
Next ws
With Worksheets("Data")
.Range(.Cells(1, 2), .Cells(UBound(varTemp), 2)).Value = varTemp
End With
End Sub
BTW: On your code, 4 is column D not E. Columns start with 1 on counting and the defintion is Cells(RowNumber, ColumnNumber) :)
Copy Single Cell's Value From All Other Worksheets
Compact
Sub CopySingleCellValuesCompact()
Dim wb As Workbook: Set wb = ActiveWorkbook ' possibly use 'ThisWorkbook'
Dim dws As Worksheet: Set dws = wb.Worksheets("Data")
Dim dCell As Range: Set dCell = dws.Range("B1")
Dim sws As Worksheet
Dim sCell As Range
For Each sws In wb.Worksheets
If Not sws Is dws Then
Set sCell = ws.Range("E16")
Set dCell = dCell.Offset(1)
dCell.Value = sCell.Value
End If
Next sws
End Sub
Argumented
Now, to get rid of the magic numbers, you could create a method...
Sub CopySingleCellValues( _
ByVal wb As Workbook, _
ByVal DestinationWorksheetName As String, _
ByVal DestinationLastCellAddress As String, _
ByVal SourceCellAddress As String)
Dim dws As Worksheet: Set dws = wb.Worksheets(DestinationWorksheetName)
Dim dCell As Range: Set dCell = dws.Range(DestinationLastCellAddress)
Dim sws As Worksheet
Dim sCell As Range
For Each sws In wb.Worksheets
If Not sws Is dws Then
Set sCell = ws.Range(SourceCellAddress)
Set dCell = dCell.Offset(1)
dCell.Value = sCell.Value
End If
Next sws
End Sub
Usage
... and in your code, use it in the following way:
Sub MyCode()
Dim wb As Workbook: Set wb = ActiveWorkbook ' possibly use 'ThisWorkbook'
CopySingleCellValues wb, "Data", "B1", "E16"
End Sub
... and keep your code clean as a whistle.
It reads something like: in the given workbook, from all worksheets except worksheet Data, copy the value from cell E16 to worksheet Data, one below the other, starting with the first cell below B1.
So I have a workbook with multiple sheets. All contain the same columns but just different categorical data. I want to grab all the data from those sheets and display/populate to a master sheet in the workbook.
I have tried different methods, but none of them are dynamic. The amount of data can be changed (+/-, either more rows or less rows) in each sheet. Each method I have found seems to be a static solution.
One example is to use the Consolidate option under the data tab, and add the respective reference/range for each sheet you would like to add (not dynamic).
Another option I found was a VBA macro, which populates the headers over and over, which I do not want to happen either, I want them all under the same header (Since the columns are already the same)
Sub Combine()
'UpdatebyExtendoffice20180205
Dim I As Long
Dim xRg As Range
Worksheets.Add Sheets(1)
ActiveSheet.Name = "Combined"
For I = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
Next
End Sub
Is this achievable?
Sheet 1
Sheet 2
Master Sheet Should Be:
But actually returns the following:
Will this constantly run each time the workbook is closed/opened/updated if it is a macro enabled workbook?
Consolidate All Worksheets
It is assumed that the Combined worksheet already exists with at least the headers which will stay intact.
To make it more efficient, only values are copied (no formats or formulas).
It will utilize the Worksheet Activate event: each time you activate (select) the combined worksheet, the data will automatically be updated.
Sheet Module of the Combined worksheet e.g. Sheet10(Combined)
Option Explicit
Private Sub Worksheet_Activate()
CombineToMaster
End Sub
Standard Module e.g. Module1
Option Explicit
Sub CombineToMaster()
Const dName As String = "Combined"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim drrg As Range
With dws.UsedRange
If .Rows.Count = 1 Then
Set drrg = .Offset(1)
Else
.Resize(.Rows.Count - 1).Offset(1).Clear
Set drrg = .Resize(1).Offset(1)
End If
End With
Dim sws As Worksheet
Dim srg As Range
Dim drg As Range
Dim rCount As Long
For Each sws In wb.Worksheets
If sws.Name <> dName Then
With sws.UsedRange
rCount = .Rows.Count - 1
If rCount > 0 Then
Set srg = .Resize(rCount).Offset(1)
drrg.Resize(rCount).Value = srg.Value
Set drrg = drrg.Offset(rCount)
End If
End With
End If
Next sws
End Sub
VBA Solution
Sub Combine()
Dim wsCombine As Worksheet: Set wsCombine = GetSheetCombine
Dim dataSheets As Collection: Set dataSheets = GetDataSheets
' Copy Header
dataSheets.Item(1).UsedRange.Rows(1).Copy
wsCombine.Range("A1").PasteSpecial xlPasteAll
wsCombine.Range("A1").PasteSpecial xlPasteColumnWidths
Application.CutCopyMode = False
' Copy data
Dim rngDest As Range: Set rngDest = wsCombine.Range("A2")
Dim srcRng As Range
Dim ws As Worksheet
For Each ws In dataSheets
' Drop header row
With ws.UsedRange
Set srcRng = .Offset(1, 0).Resize(.Rows.Count - 1)
End With
srcRng.Copy rngDest
Set rngDest = rngDest.Offset(srcRng.Rows.Count)
Next ws
Application.CutCopyMode = False
MsgBox "Done!", vbInformation
End Sub
Private Function GetSheetCombine() As Worksheet
Dim ws As Worksheet
With Worksheets
On Error Resume Next
Set ws = .Item("Combine")
On Error GoTo 0
If ws Is Nothing Then
Set ws = .Add(Before:=.Item(1))
ws.Name = "Combine"
Else
ws.Cells.Clear ' clear any existing data
End If
End With
Set GetSheetCombine = ws
End Function
Private Function GetDataSheets() As Collection
Dim Result As New Collection
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "Combine" Then Result.Add ws
Next ws
Set GetDataSheets = Result
End Function
As to your question "Will this run every time macro enabled workbook is open?".
No. You will need to put this in a VBA module and run it every time you need, via the Macro dialog (View->Macros), or link a button to it.
I have a workbook with one main index sheet and a template sheet.
I have information in my index sheet.
Each line in the main sheet should generate a new sheet.
I want to duplicate the template with all the data in there, but with a name from each line from main sheet.
I can create the sheets with the right names, but with zero data in them.
This is the VBA code to make a new sheet with the right name. I need to copy all the data into all the new sheets. It comes from this blog post by Oscar Cronquist:
'Name macro
Sub CreateSheets()
'Dimension variables and declare data types
Dim rng As Range
Dim cell As Range
'Enable error handling
On Error GoTo Errorhandling
'Show inputbox to user and prompt for a cell range
Set rng = Application.InputBox(Prompt:="Select cell range:", _
Title:="Create sheets", _
Default:=Selection.Address, _
Type:=8)
'Iterate through cells in selected cell range
For Each cell In rng
'Check if cell is not empty
If cell <> "" Then
'Insert worksheet and name the worksheet based on cell value
Sheets.Add.Name = cell
End If
'Continue with next cell in cell range
Next cell
'Go here if an error occurs
Errorhandling:
'Stop macro
End Sub
Create Template Worksheets
Sub CreateTemplateWorksheets()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ash As Object: Set ash = wb.ActiveSheet
Dim lws As Worksheet: Set lws = wb.Worksheets("Main Index")
Dim lrg As Range
Set lrg = lws.Range("A2", lws.Cells(lws.Rows.Count, "A").End(xlUp))
Dim sws As Worksheet: Set sws = wb.Worksheets("Template")
Dim lCell As Range
Dim dws As Worksheet
Dim dwsCount As Long
Dim dName As String
For Each lCell In lrg.Cells
dName = CStr(lCell.Value)
If Len(dName) > 0 Then
On Error Resume Next
Set dws = wb.Worksheets(dName)
On Error GoTo 0
If dws Is Nothing Then
sws.Copy After:=wb.Sheets(wb.Sheets.Count)
Set dws = ActiveSheet
dws.Name = dName
dwsCount = dwsCount + 1
End If
Set dws = Nothing
End If
Next lCell
ash.Select
MsgBox "Worksheets created: " & dwsCount, vbInformation
End Sub
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.
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