I am trying to write a macro that goes into an infinite amount of sheets and copies and pastes a data range from A10:E10, A11:E11 and so on until it hits a blank cell until pastes it into a new tab until it has gone through each sheet and grabbed the data. I have tried to use the code below, but it will only let me paste one cell and if I change the range to more than one it pastes over and leaves out data. Any Help would be greatly appreciated.
Dim sh As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim i As Integer
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ThisWorkbook
Set DestSh = wb.Sheets("Combined")
' Loop through worksheets that start with the name "20"
i = 4
For Each sh In ActiveWorkbook.Worksheets
If sh.Name = "Data" Then Exit Sub
sh.Range("E10").Copy
With DestSh.Range("AF" & i)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
i = i + 1
Next
Related
I am new to VBA and I am trying to copy data from one workbook to another. In my "copying workbook", wb1 (.dbf format) I have 3 sets of data I want to copy to my "pasting workbook", wb2 (.xlsm format).
I need to copy three "chunks" (which I call bands) of data from one WB to the other. Band1 ranges from "C2:M5", Band2 from "N2:X5" and Band3 from "Y2:AI5".
I want the user to be able to choose where he is pasting each band, ideally by asking him to select only the first cell of the range for each band.
So far, I have the code showed below. It only copies and pastes one band at a time, which means I have to run it three times. My goal is to have a routine which copies and pastes the data all at once (running the code once) and that pastes the bands/"chuncks" whenever the user wants them to.
I hope this was clear enough. Thank you in advance for all your help!
Sub CopyData()
' Keyboard shortcut: Ctrl+d
Dim band As Integer
Dim wb1 As Workbook
Dim wb2 As Workbook
Set band = InputBox("Choose bands 1, 2 or 3:")
Set wb1 = Workbooks.Open("C:\Users\mmm\CopyFile.dbf") ' File I want to copy the data from
Set wb2 = Workbooks.Open("C:\Users\mmm\PasteFile.xlsm") ' File I want to paste my data to
If band = 1 Then
wb1.Worksheets(dbf_name).Range("C2:M5").Copy 'Range of Band1 to copy
wb1.Close savechanges:=False
Application.DisplayAlerts = True
Application.DisplayAlerts = False
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
ElseIf band = 2 Then
wb1.Worksheets(dbf_name).Range("N2:X5").Copy 'Range of Band2 to copy
wb1.Close savechanges:=False
Application.DisplayAlerts = True
Application.DisplayAlerts = False
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
ElseIf band = 3 Then
wb1.Worksheets(dbf_name).Range("Y2:AI5").Copy 'Range of Band3 to copy
wb1.Close savechanges:=False
Application.DisplayAlerts = True
Application.DisplayAlerts = False
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
End If
End Sub
[UPDATE WITH FINAL CODE]
Sub CopyData()
' Keyboard shortcut: Ctrl+d
Dim dbf_path As String
Dim dbf_name As String
Dim rCopy As Range
Dim i As Long
Dim rPaste As Range
Dim wb1 As Workbook
dbf_path = "C:\Users\mmm\CopyFile.dbf"
dbf_name = "filename_dbf"
Set wb1 = Workbooks.Open(dbf_path)
ThisWorkbook.Activate
Set rCopy = wb1.Worksheets(dbf_name).Range("C2:M5,N2:X5,Y2:AI5")
For i = 1 To rCopy.Areas.Count 'loop through each distinct block or area
Set rPaste = Application.InputBox("Enter starting cell for range " & i, Type:=8) 'invite paste cell, specifying range input
If rPaste.Count > 1 Then Set rPaste = rPaste(1) 'if more than one cell selected use the first one
rCopy.Areas(i).Copy rPaste 'paste
Next i
wb1.Close savechanges:=False
End Sub
Here's a simple exampleto show how you might set the paste destination for each block via an input box. Hopefully you can adapt it to your precise set up.
Sub x()
Dim rCopy As Range, i As Long, rPaste As Range
Set rCopy = Range("C2:M5,N2:X5,Y2:AI5") 'define ranges to copy
For i = 1 To rCopy.Areas.Count 'loop through each distinct block or area
Set rPaste = Application.InputBox("Enter starting cell for range " & i, Type:=8) 'invite paste cell, specifying range input
If rPaste.Count > 1 Then Set rPaste = rPaste(1) 'if more than one cell selected use the first one
rCopy.Areas(i).Copy rPaste 'paste
Next i
End Sub
I am using the macro below by clicking a button each time I want to run it. This works ok but is quite time consuming.
In the Summary sheet (range H2:H21) of the workbook I have a list of ID numbers which I have been manually pasting into E3 before running the macro.
Instead of doing this I would like to amend the macro so it loops through all the IDs when I click the button.
The workbook is quite big and takes a while to calculate each time a new ID is pasted in so this needs to be factored in.
Can anyone show me have to do these things?
Sub CreateNewSheet()
Application.ScreenUpdating = False
Application.Calculation = xlManual
With Workbooks("Batsmen.xlsx").Worksheets.Add()
.Name = ThisWorkbook.Worksheets("Summary").Range("E3").Value
End With
With ThisWorkbook.Worksheets("Summary").Range("A22:J63").Copy
Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteFormats
Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
Workbooks("Batsmen.xlsx").Sheets(1).Range("A:J").Font.Size = 10
End With
With ThisWorkbook.Worksheets("Summary").Range("A22:J27").Copy
With Workbooks("Batsmen.xlsx").Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Font.Size = 10
End With
End With
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
This can be optimized, but should get you started.
Check the code's comments and adjust it to fit your needs.
You can put the cursos inside the Process procedure, press F8 key and see what the code does.
EDIT: Added summarySheet.Range("E3").value = cell.value to the loop
Option Explicit
Public Sub Process()
Dim targetWorkbook As Workbook
Dim summarySheet As Worksheet
Dim sourceRange As Range
Dim cell As Range
' Customize this settings
Set targetWorkbook = Workbooks("Batsmen.xlsx")
Set summarySheet = ThisWorkbook.Worksheets("Summary")
Set sourceRange = summarySheet.Range("H2:H21")
Application.ScreenUpdating = False
Application.Calculation = xlManual
' Loop through each cell in source range
For Each cell In sourceRange.Cells
' Validate that cell has a value
If cell.Value <> vbNullString Then
' Fill E3 with cell value from range in column H
summarySheet.Range("E3").value = cell.value
' Execute procedure to create new sheet
CreateNewSheet targetWorkbook, cell.Value, summarySheet
End If
Next cell
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
Private Sub CreateNewSheet(ByVal targetWorkbook As Workbook, ByVal newSheetName As String, ByVal summarySheet As Worksheet)
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets.Add
targetSheet.Name = newSheetName
summarySheet.Range("A22:J63").Copy
With targetSheet
.Range("A1").PasteSpecial Paste:=xlPasteValues
.Range("A1").PasteSpecial Paste:=xlPasteFormats
.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
.Range("A:J").Font.Size = 10
End With
summarySheet.Range("A22:J27").Copy
With targetSheet.Range("A" & Rows.Count).End(xlUp).Offset(2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Font.Size = 10
End With
End Sub
Let me know if it works
The code below should answer your question because it does create the sheets you want.
Sub CreateNewSheet()
Dim Wb As Workbook
Dim WbBat As Workbook
Dim WsSum As Worksheet
Dim NamesRange As Range
Dim i As Integer
Dim TabName As String
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With
Set Wb = ThisWorkbook
Set WbBat = Workbooks("Batsmen.xlsx")
Set WsSum = Wb.Worksheets("Summary")
Set NamesRange = WsSum.Range("H2:H21")
For i = 1 To NamesRange.Cells.Count
TabName = Trim(NamesRange.Cells(i).Value)
If Len(TabName) Then ' skip if name is blank
With WbBat.Worksheets.Add()
.Name = TabName
WsSum.Range("A22:J63").Copy Destination:=.Cells(1, "A")
WsSum.Range("A22:J27").Copy Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(2)
.Range("A:J").Columns.AutoFit
.Range("A1:J" & .Cells(.Rows.Count, "A").End(xlUp).Row).Font.Size = 10
End With
End If
Next i
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With
End Sub
Regrettably, it doesn't provide you usable code because it pastes the same data to all sheets. I presume that you have a plan how to vary the data. Unfortunately, I failed to understand such a plan from your question. However, I suspect that you will be able to modify the code to make it useful.
I'm trying to write this little macro to copy several sheets stored in an array and paste them as values to new workbook, maintaining sheets' names and order. I've found some solutions but not exactly matching my situation.
This is for excel macro where we try sending dashboard thru mail along with attachment but need to added sheet only paste values with same formatting
Option Explicit
Sub Send_Email_With_snapshot()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Summary")
ActiveWorkbook.RefreshAll
Worksheets(Array("Calculation", "Retailer Wise_Data", "TM Wise", "Channel_Base")).Copy
Worksheets("Calculation").Range("a1:Ax54").Copy
Worksheets("Calculation").Range("a1:Ax54").PasteSpecial _
Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
With ActiveWorkbook
.SaveAs Filename:="E:\Automation\New folder\" & "RAEO_Dashboard_MTD.xlsx", FileFormat:=51
.Close savechanges:=True
Application.DisplayAlerts = False
Dim lr As Integer
lr = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
sh.Range("A1:T120").Select
With Selection.Parent.MailEnvelope.Item
.to = "xyz.com"
.cc = ""
.Subject = sh.Range("AN14").Value
.attachments.Add "D:\RAEO_Dashboard_MTD.xlsx"
.send
End With
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
End With
End Sub
I wasn't sure if you meant when you wrote "with same formatting". If by that you mean cells formatting (eg. color, size, borders, visible/hidden propertie, etc.) then I added another section at the end of this answer to address that. However, if you only need number formats to stay the same, here is how you could do it.
Paste values and number formats
The 2 key elements here are:
To use .PasteSpecial Paste:=xlPasteValuesAndNumberFormats to paste values and number formats at the same time.
Use a For loop to go over your array of sheets.
Implemented this would look like this:
Sub CopySheetsValuesAndNumberFormats()
ActiveWorkbook.RefreshAll 'In case you have Pivot Tables to refresh
Dim ListOfSheets() As Variant
ListOfSheets = Array("Calculation", "Retailer Wise_Data", "TM Wise", "Channel_Base") 'Example list based on the question
Dim SourceWorkbook As Workbook
Set SourceWorkbook = ThisWorkbook 'Or Workbooks("Workbook Name")
Dim DestinationWorkbook As Workbook
Set DestinationWorkbook = Workbooks.Add
Dim i As Long
For i = LBound(ListOfSheets) To UBound(ListOfSheets)
Dim SourceSheet As Worksheet
Set SourceSheet = SourceWorkbook.Worksheets(ListOfSheets(i))
Dim DestinationSheet As Worksheet
Set DestinationSheet = DestinationWorkbook.Worksheets.Add(After:=DestinationWorkbook.Worksheets(DestinationWorkbook.Worksheets.Count)) 'Insert in last position
DestinationSheet.Name = SourceSheet.Name
Dim SourceRange As Range
Set SourceRange = SourceSheet.UsedRange
Dim DestinationRange As Range
Set DestinationRange = DestinationSheet.Range(SourceRange.Address)
'Paste values and number formats
SourceRange.Copy
DestinationRange.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Next i
'Delete initial sheets
For i = 1 To 3
On Error Resume Next
Application.DisplayAlerts = False
DestinationWorkbook.Worksheets("Sheet" & i).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Next i
End Sub
Paste values and cells formatting
In order to copy the formatting, you are going to have to copy from all Cells as opposed to from the UsedRange in the first section of this answer. The reason is that some columns might have some formatting that apply to all the cells inside a column, but not all these cells will be part of the UsedRange.
The only part of the code that you need to replace from the code above is the one starting with "Paste values and number formats". You would need to replace this part with the following:
'Paste values and cells formatting
SourceSheet.Cells.Copy
DestinationSheet.Cells.PasteSpecial Paste:=xlPasteAll
SourceRange.Copy
DestinationRange.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
I am trying to copy all sheets (7 sheets) from workbook1(wb1) to wb2. wb1 contains command buttons but I don't want them in my new workbook. I am using loop to copy individual sheets from one workbook to another. but error comes while copying to 2nd sheet. I am using the code as below :-
Public Sub CommandButton1_Click()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim i As Integer
i = 1
Set wb1 = ActiveWorkbook
Set ws1 = ActiveSheet
Set wb2 = Workbooks.Add
With wb2
.Title = "My Sales"
.Subject = "Sales"
.SaveAs Filename:="mysales.xls"
End With
For i = 1 To 7
Dim row As Long
Dim column As Long
wb1.Activate
wb1.Sheets(i).Activate
column = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).column
row = ActiveSheet.Range("A" & Rows.Count).End(xlUp).row
Application.CutCopyMode = False
ActiveSheet.Range(Cells(1, 1), Cells(row, column)).Select
Selection.Copy
wb2.Sheets(i).Range("A1").PasteSpecial
Application.CutCopyMode = False
next i
End Sub
Loop is running succesfully for the first time but for i=2, code gives error
Sub M_snb()
thisworkbook.sheets(array("one","two","three","four","five","six","seven")).copy
do until activeworkbook.sheets("one").oleobjects.count=0
activeworkbook.sheets("one").oleobjects(1).delete
loop
activeworkbook.saveas "G:\OF\new.xlsx",51
End Sub
I have a master spreadsheet Master Spreadsheet.xlsm and I want to use it to create another spreadsheet defined by OutputFN.
This second spreadsheet needs to be a copy of the first but only containing the visible cells from visible worksheets in the first.
I have found code to copy just the visible sheets and other code to copy just the visible cells but not the two together. Any help would be much appreciated.
This is what I've got so far:
Private Sub saveone()
Dim OutputFN As String
Dim OutputWB As Workbook
Dim SourceWB As Workbook
Dim i As Integer
i = 1
Set SourceWB = Application.ActiveWorkbook
OutputFN = ThisWorkbook.Worksheets("Setup Page").Range("B12").Value
Set OutputWB = Workbooks.Add
'Selects active (not hidden cells) from visible sheets and copies
For Each Sheet In ThisWorkbook.Sheets
If Sheet.Visible = True Then
ThisWorkbook.ActiveSheet.Cells. _
SpecialCells(xlCellTypeVisible).Copy
'Pastes into new workbook
Worksheets(i).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
'Saves new file as output filename in the directory created earlier
ActiveWorkbook.SaveAs (OutputFN)
i = i + 1
End If
Next
End Sub
Something like this
I've tidied up the variables and tweaked the logic a little as well
Private Sub saveone()
Dim OutputFN As String
Dim OutputWB As Workbook
Dim SourceWB As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Set SourceWB = ThisWorkbook
OutputFN = SourceWB.Worksheets("Setup Page").Range("B12").Value
Set OutputWB = Workbooks.Add(1)
Application.ScreenUpdating = False
For Each ws In SourceWB.Sheets
If ws.Visible Then
Set ws2 = OutputWB.Sheets.Add(After:=OutputWB.Sheets(OutputWB.Sheets.Count))
ws.Cells.SpecialCells(xlCellTypeVisible).Copy
ws2.[a1].PasteSpecial xlPasteValues
ws2.[a1].PasteSpecial xlPasteFormats
End If
Next
Application.ScreenUpdating = True
ActiveWorkbook.SaveAs (OutputFN)
End Sub