The code below copies all worksheet contents from source workbook into destination workbook. Worksheet names are exactly same. The code copies the data from source in exactly the same order/range ("A2:A700," & _ "D2:D700," & _"C2:C700") into destination workbook. However, I want the data from source in the range above to go into a different range(I3,k3 and AC3) on the destination workbook. Any assistance is appreciated.
Option Explicit
Sub seunweb()
'this macro copies from one workbook to another
Dim wbSource As Workbook, wbDestination As Workbook
Dim ws As Worksheet, rng As Range
Dim NextRow As Long, LastRow As Long
Application.ScreenUpdating = False
Set wbSource = Workbooks.Open("D:\test.xls")
Set wbDestination = ThisWorkbook
For Each ws In wbSource.Sheets
For Each rng In ws.Range("A2:A700," & _
"D2:D700," & _
"C2:C700").Areas
wbDestination.Sheets(ws.Name).Range(rng.Address).Value = rng.Value
Next rng
Next ws
wbSource.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
Instead of your for loop, use somthing like
Set rng = ws.Range("A2:A700")
wbDestination.Sheets(ws.Name).Range("I3").Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Set rng = ws.Range("D2:D700")
wbDestination.Sheets(ws.Name).Range("K3").Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
' continue this this for each source range
Related
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'm trying to copy and paste a certain value from a cell in one sheet matching a range in another workbook. The code runs fine, doesn't give any run-time errors, but will not paste in the range declared in the other workbook. Code below
Sub ConditionalCopy()
Dim dest As Worksheet
Set dest = ActiveWorkbook.Worksheets("VCP Plan")
Dim rng As Range, cell As Range
Set rng = Range("D:D")
Dim OpenWorkBook As Variant
OpenWorkBook = Application.GetOpenFilename("Excel Files (*.xlsx* (*.xlsx*),")
If OpenWorkBook <> False Then
Workbooks.Open (OpenWorkBook)
End If
For Each cell In rng
If cell.Value = "26ASA00015D007" Then
cell.Offset(0, 3).Copy Destination:=dest.Range("E3")
End If
Next cell
End Sub
It is unclear from your description and your code which workbook/worksheet you want to compare and copy, and which workbook/worksheet you want to copy to.
You'll need to be more specific
I've made a guess at what you are trying to do. If I've got it wrong, simply adjust the references to suit
Something like
Sub ConditionalCopy()
Dim wbSource as Workbook
Dim wsSource as Worksheet
Dim rSource as Range
Dim wbDest as Workbook
Dim wsDest as Worksheet
Dim rDest as Range
Set wbDest = ActiveWorkbook ' Are you sure?
Set wsDest = wbDest.Worksheets("VCP Plan")
Set rDest = ws.Range("E3")
Dim OpenWorkBook As Variant
OpenWorkBook = Application.GetOpenFilename("Excel Files (*.xlsx* (*.xlsx*),")
If OpenWorkBook <> False Then
Set wbSource = Workbooks.Open(OpenWorkBook)
Else
Exit Sub
End If
Set wsSource = wbSource.Worksheets("NameOfSourceSheet")
Dim cell As Range
With wsSource
' Column D from row 1 to last used row
Set rSource = .Range(.Cells(1, 4), .Cells(.Rows.Count, 4).End(xlUp))
End With
For Each cell In rSource
If cell.Value = "26ASA00015D007" Then
cell.Offset(0, 3).Copy Destination:=rDest
' You probably don't want to overwrite each time, so
Set rDest = rDest.Offset(1, 0)
End If
Next cell
End Sub
I want to copy the value from current sheet to another workbooks with auto filter by creating new one, once I run the code I got the error:
Object variable or with block variable not set
Here's the code:
Sub copyvaluetoanothersheet()
Dim selectrange As Range
Dim wb As Workbook
Dim Dsheet As Worksheet
Dim Lastrow As Long
Application.ScreenUpdating = False
Set wb = Workbooks.Add
Set Dsheet = wb.Worksheets(1)
Lastrow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
selectrange = Sheet2.Range("A2:BP" & Lastrow)
With Worksheets("Production data")
.AutoFilterMode = False
selectrange.AutoFilter field:="Branch", Criteria1:="Direct Response"
selectrange.SpecialCells(xlCellTypeVisible).EntireRow.Copy
End With
Dsheet.PasteSpecial xlPasteValues
Application.ScreenUpdating = True
End Sub
Many thanks
You must use Set when assigning object variables (you've done it elsewhere).
Set selectrange = Sheet2.Range("A2:BP" & Lastrow)
Note too that your mixture of sheet code names, tab names, and indexes is confusing, and that your code will error if nothing is visible.
Try following
Sub cpVisible()
Dim MyProdName As String
Dim FilteredRange As Range
Dim myArr As Variant
Sheets("Production Data").Range("$A$2:$BP$50000").AutoFilter Field:="Branch", Criteria1:="Direct Response"
Set FilteredRange = Sheets("Production Data").Range("$A$2:$BP$50000").SpecialCells(xlCellTypeVisible)
FilteredRange.Copy Sheets("Dsheet").Range("A1")
End Sub
i want to copy data from worksheets in workbook "Miz" to worksheets in workbook "Prime" by the worksheets names. meaning, i want the data from worksheet "assets" in Miz to be copied to worksheet "assets" in workbook "Prime" by loop (cause i have many worksheets) and so on for other worksheets.
p.s
i got the code to work but it doesn't loop through all the sheets. it only copies the first one and that's it.
Sub WorksheetLoop()
Dim WS_Count As Integer
Dim I As Integer
Dim WsSource As Workbook
Dim WsTarget As Workbook
Dim LastCell As Variant
Set WsSource = Workbooks("Prime.xlsm")
Set WsTarget = Workbooks("Miz.xlsm")
WsTarget.activate
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
If ActiveWorkbook.Worksheets(I).Name = WsSource.Worksheets(I).Name Then
WsTarget.activate
LastCell = Range("A1").SpecialCells(xlCellTypeLastCell).Address
ActiveSheet.Range("A1", LastCell).Select
Selection.Copy
WsSource.activate
ActiveWorkbook.Worksheets(I).activate
Range("F1").Select
Selection.PasteSpecial Paste:=xlPasteAll
End If
Next I
End Sub
This could be done better, but i'm tired. The code loops through each workbook and copies the used range of the source workbook to the destination workbook range F1. Both workbooks must be open, or else you will receive the Subscript out of range error.
Sub WsLoop()
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim WsSource As Workbook
Dim WsTarget As Workbook
Dim Rng As Range
Set WsSource = Workbooks("Miz.xlsm")
Set WsTarget = Workbooks("Prime.xlsm")
For Each ws In WsSource.Sheets
Set Rng = ws.UsedRange
For Each ws1 In WsTarget.Sheets
If ws.Name = ws1.Name Then
Rng.Copy Destination:=ws1.Range("F1")
End If
Next ws1
Next ws
End Sub
I'm currently doing VBA project which need to copy from a workbook to another, which the WBookPst is the workbook I firstly open (use) meanwhile WBookCopy is the workbook where I open based on the links where I got by listing all ".xslt" format in a File into my Sheet1 of my first workbook. Here is my code :
Sub SortFiles()
'Set up your variables and turn off screen updating.
'Dim iCounter As Integer
Application.ScreenUpdating = False
'Sort the rows based on the data in column C
Columns("A:C").Sort key1:=Range("C2"), _
order1:=xlDescending, Header:=xlYes
Application.ScreenUpdating = True
Dim WBookCopy As Workbook
Dim WBookPst As Workbook
Dim filePath As String
Dim sheetName As String
Dim sheetCopy As Worksheet
Dim sheetPate As Worksheet
Dim rngCopy As Range
Dim rngPst As Range
filePath = Range("B2").Value
Set WBookCopy = Workbooks.Open(filePath)
Columns(30).Insert
For i = 1 To Sheets.count
Cells(i, 30) = Sheets(i).Name
Next i
sheetName = Range("AD1").Value
Set sheetCopy = WBookCopy.Worksheets(sheetName)
Set rngCopy = sheetCopy.Range("A:AA").Copy
Set WBookPst = ThisWorkbook
Set sheetPaste = WBookPst.Worksheets("Sheet1").Activate
Set rngCopy = sheetPaste.Range("A:AA").Select
ActiveSheet.Paste
End Sub
At Set rngCopy = sheetCopy.Range("A:AA").Copy there's error "Objects required".
What does that mean?
By the way, is how I copy and paste the data between sheets correct?
The issue is that rngCopy is of type range and you can't set it equal to a method (copy). Remove the .Copy and you should be fine. You also don't need to set the worksheet out range to a variable. You could just do one line that says WBookCopy.SheetName.Range("A:AA").Copyand then another line to paste.
As #Wyatt mentioned - your copy\paste syntax is incorrect
Here are 2 ways to do it:
Worksheets("Sheet1").Range("A:AA").Copy
Worksheets("Sheet2").Range("A1").PasteSpecial xlPasteAll
or
Worksheets("Sheet1").Range("A:AA").Copy Destination:=Worksheets("Sheet2").Range("A1")