I'm looping through a Scripting Dictionary and call a function that loads specific filtered and sorted datasets to a sheet named "DonneesFiltrees".
I want to create a single workbook and through this loop add Sheets to the new workbook and copy paste "DonneesFiltrees" dataset into each sheets.
There is my code at this moment, my loop and function are working great but I have no clue about how to insert multiple sheet to a new workbook
Set wsData = Worksheets("DonneesFiltrees")
Application.ScreenUpdating = False
Dim varkey As Variant
'ActiveWorkbook.SaveAs (ThisWorkbook.Path & "\data_output\export_du_" & Format(Now(), "DD-MMM-YYYY hh mm AMPM") & ".xlsx")
For Each varkey In DicTheme.Keys
Call ChargerLesDonnees(CStr(DicTheme(varkey)), Me.listEntreprise.Value)
If wsData.Range("A2").Value <> "" Then
'Create sheet into new Workbook,
'Set DicTheme(varkey) as sheet name,
'copy paste wsData sheet dataset into this new sheet.
End If
Next varkey
Application.ScreenUpdating = True
Thank you in advance for your help.
Please have a look at the modified code of yours
Set wsData = Worksheets("DonneesFiltrees")
Application.ScreenUpdating = False
Dim varkey As Variant
'ActiveWorkbook.SaveAs (ThisWorkbook.Path & "\data_output\export_du_" & Format(Now(), "DD-MMM-YYYY hh mm AMPM") & ".xlsx")
' Create a new workbook
Dim wkb As Workbook
Set wkb = Workbooks.Add
For Each varkey In DicTheme.Keys
Call ChargerLesDonnees(CStr(DicTheme(varkey)), Me.listEntreprise.Value)
If wsData.Range("A2").Value <> "" Then
'Create sheet into new Workbook,
Dim wks As Worksheet ' no harm if one puts the declartion in the loop
Set wks = wkb.Worksheets.Add
'Set DicTheme(varkey) as sheet name,
wks.Name = DicTheme(varkey) ' DicTheme(varkey) should be a valid sheet name
'copy paste wsData sheet dataset into this new sheet.
End If
Next varkey
Application.ScreenUpdating = True
Further reading
Workbooks Add
Worsheets Add
Thanks a lot for bringing help, here is the final code in case it can interest people. As the workbook is created with a default worksheet I'm deleting it at the end before to set a name and save the file.
Set wsData = Worksheets("DonneesFiltrees")
Application.ScreenUpdating = False
Dim varkey As Variant
' Create a new workbook
Dim wkb As Workbook
Set wkb = Workbooks.Add
ThisWorkbook.Activate
For Each varkey In DicTheme.Keys
Call ChargerLesDonnees(CStr(DicTheme(varkey)), Me.listEntreprise.Value)
If wsData.Range("A2").Value <> "" Then
'Create sheet into new Workbook,
Dim wks As Worksheet ' no harm if one puts the declartion in the loop
Set wks = wkb.Worksheets.Add
'Set DicTheme(varkey) as sheet name,
wks.Name = DicTheme(varkey) ' DicTheme(varkey) should be a valid sheet name
'copy paste wsData sheet dataset into this new sheet.
wsData.Visible = xlSheetVisible
wsData.ListObjects(1).HeaderRowRange.Copy Destination:=wks.Range("A1")
wsData.ListObjects(1).DataBodyRange.Copy Destination:=wks.Range("A2")
wsData.Visible = xlSheetHidden
End If
Next varkey
Application.DisplayAlerts = False
wkb.Sheets("Feuil1").Delete
Application.DisplayAlerts = True
wkb.SaveAs (ThisWorkbook.Path & "\data_output\export_GLOBAL_de_" & Me.listEntreprise.Value & "_du_" & Format(Now(), "DD-MMM-YYYY hh mm AMPM") & ".xlsx")
wkb.Close
ThisWorkbook.Activate
wsData.Cells.Clear
Application.ScreenUpdating = True
Related
I am trying to make a macro where I separate my tabs (one from each client) into new excel files and then also filter, copy and paste (from a sheet called database) in each of those excel files just created the informations regarding each client.
When I try to run the code, it separate the tabs just as expected, but it does not copy and paste the information from my database sheet. I got the following error: "Application-defined or object-definied error" for the line "For Each x In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))"
How can I fix it?
Sub Separar_guias()
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook
'Specify sheet name in which the data is stored
sht = "database"
'Workbook where VBA code resides
Set Workbk = ThisWorkbook
'change filter column in the following code
last = Workbk.Sheets(sht).Cells(Rows.Count, "AA").End(xlUp).Row
With Workbk.Sheets(sht)
Set rng = .Range("A1:T" & last)
End With
Workbk.Sheets(sht).Range("AA1:AA" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
' Loop through unique values in column
For Each x In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=27, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
'Add New Workbook in loop
Set newBook = Workbooks.Add(xlWBATWorksheet)
newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
newBook.Activate
ActiveSheet.Paste
End With
'Save new workbook
newBook.SaveAs x.Value & ".xlsx"
'Close workbook
newBook.Close SaveChanges:=False
Next x
' Turn off filter
Workbk.Sheets(sht).AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
I have VBA code which creates a new workbook based on a template and saves it with a name based on a list.
I only want the code to create the workbooks IF a statement is true.
See following example:
Sheet "MC_TestSheetGenerator"
The macro ONE_CreateTestsheetWB_TEST_NEW_INST_01 creates new workbooks based on a template called "TEST-NEW-INST-01" and saves the file with the name in col "I" of "MC_TestSheetGenerator".
How can I only do that if the adjacent cell H equals "TEST-NEW-INST-01"?
In this example it should only create two new workbooks as the value is only present in row 3 and 8.
Sub ONE_CreateTestsheetWB_TEST_NEW_INST_01()
Application.DisplayAlerts = False
Dim wb As Workbook, sh1 As Worksheet, lr As Long, rng As Range
Set sh1 = Sheets("MC_TestSheetGenerator") 'Edit sheet name
lr = sh1.Cells(Rows.Count, "I").End(xlUp).Row
Set rng = sh1.Range("I3:I" & lr)
For Each c In rng
Sheets("TEST-NEW-INST-01").Copy 'Edit sheet name
Set wb = ActiveWorkbook
wb.Sheets(1).Range("A3") = c.Value
wb.SaveAs ThisWorkbook.Path & "\" & c.Value & ".xlsx", 51
wb.Close False
Application.DisplayAlerts = True
Next
End Sub
Inside your For loop just add an If statement using property OFFSET :
For Each c In Rng
If c.Offset(0, -1).Value = "TEST-NEW-INST-01" Then
Sheets("TEST-NEW-INST-01").Copy 'Edit sheet name
Set wb = ActiveWorkbook
wb.Sheets(1).Range("A3") = c.Value
wb.SaveAs ThisWorkbook.Path & "\" & c.Value & ".xlsx", 51
wb.Close False
Application.DisplayAlerts = True
End If
Next
Range.Offset property
(Excel)
Also, as advice, I'm pretty sure your Application.DisplayAlerts = True could be outside of the loop.
OFFSET property will be the easiest way to introduce it in your code OR you can change the loop type and loop directly in that column and check the condition after.
Also, I agree with #Foxfire And Burns And Burns, the Application.DisplayAlerts = True should be set outside the loop, preferably at the end of the code/sub.
I have revamped your code, please have a look:
Sub ONE_CreateTestsheetWB_TEST_NEW_INST_01()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim wb As Workbook, wbnew As Workbook
Dim sh1 As Worksheet, lr As Long, rng As Range
Set wb = ThisWorkbook
Set sh1 = wb.Sheets("MC_TestSheetGenerator")
lr = sh1.Cells(Rows.Count, "I").End(xlUp).Row
For i = 3 To lr
If sh1.Range("H" & i).Value2 = "TEST-NEW-INST-01" Then
Set wbnew = Workbooks.Add
wb.Sheets("TEST-NEW-INST-01").Copy Before:=wbnew.Sheets(1)
wbnew.SaveAs wb.Path & "\" & sh1.Range("I" & i).Value2, FileFormat:=51
wbnew.Close
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have multiple workbooks in a single folder. All the workbooks share the same format and I wish to copy from the same range on the first worksheet in all workbooks and add this to a single worksheet of a newly created workbook.
The code so far:
Sub OpenAllCompletedFilesDirectory()
Dim Folder As String, FileName As String
Folder = "pathway..."
FileName = Dir(Folder & "\*.xlsx")
Do
Dim currentWB As Workbook
Set currentWB = Workbooks.Open(Folder & "\" & FileName)
CopyDataToTotalsWorkbook currentWB
FileName = Dir
Loop Until FileName = ""
End Sub
Sub AddWorkbook()
Dim TotalsWorkbook As Workbook
Set TotalsWorkbook = Workbooks.Add
outWorkbook.Sheets("Sheet1").Name = "Totals"
outWorkbook.SaveAs FileName:="pathway..."
End Sub
Sub CopyDataToTotalsWorkbook(argWB As Workbook)
Dim wsDest As Worksheet
Dim lDestLastRow As Long
Dim TotalsBook As Workbook
Set TotalsBook = Workbooks.Open("pathway...")
Set wsDest = TotalsBook.Worksheets("Totals")
Application.DisplayAlerts = False
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy
wsDest.Range("A" & lDestLastRow).PasteSpecial
Application.DisplayAlerts = True
TotalsBook.Save
End Sub
This works - to a point. It does copy the correct ranges across and place the results one below another on the "Totals" worksheet of the "Totals" workbook, but it raises a 'Subscript out of range' error on:
argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy
after data from the last workbook has been pasted.
How can I tidy this code so that it works without error?
I imagine there is scope to improve the code too.
I'd maybe do something like this.
Note you can just open the summary workbook once before looping over the files.
Sub SummarizeFiles()
'Use `Const` for fixed values
Const FPATH As String = "C:\Test\" 'for example
Const TOT_WB As String = "Totals.xlsx"
Const TOT_WS As String = "Totals"
Dim FileName As String, wbTot As Workbook, wsDest As Worksheet
'does the "totals" workbook exist?
'if not then create it, else open it
If Dir(FPATH & TOT_WB) = "" Then
Set wbTot = Workbooks.Add
wbTot.Sheets(1).Name = TOT_WS
wbTot.SaveAs FPATH & TOT_WB
Else
Set wbTot = Workbooks.Open(FPATH & TOT_WB)
End If
Set wsDest = wbTot.Worksheets(TOT_WS)
FileName = Dir(FPATH & "*.xlsx")
Do While Len(FileName) > 0
If FileName <> TOT_WB Then 'don't try to re-open the totals wb
With Workbooks.Open(FPATH & FileName)
.Worksheets("Weekly Totals").Range("A2:M6").Copy _
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
.Close False 'no changes
End With
End If
wbTot.Save
FileName = Dir 'next file
Loop
End Sub
Beginner in VBA.
What I'm attempting to do:
Copy the first 5 rows _ row 'x' in current worksheet, and paste in a new workbook
New workbooks should be saved in the same directory
This should repeat for every row below the first 5, i.e. rows 1-5 + 6, rows 1-5 + 7, rows 1-5 + 8, etc.
When pasting the rows into the new workbook, I don't want to copy formulas, just format and values
This is what I have so far:
Sub CommandButton1_Click()
Dim MyBook As Workbook, newBook As Workbook
Dim FileNm As String
Set MyBook = ThisWorkbook
FileNm = ThisWorkbook.Path & "\" & "TEST-BOOK.xlsx"
Set newBook = Workbooks.Add
With newBook
MyBook.Sheets("Sheet1").Rows("1:5").Copy .Sheets("Sheet1").Rows("1")
'Save new wb
.SaveAs Filename:=FileNm, CreateBackup:=False
.Close Savechanges:=False
End With
End Sub
It copies the rows 1-5, but I don't know how to add the dynamic extra row-- it also copies all the formulas and embeds them. Assuming the Filename would also have to be in some sort of loop?
Thank you.
hope this helps,
Sub CommandButton1_Click()
Dim wb As Workbook, FileNm As String, LastRow As Long, Headers As Range, wbTemp As Workbook, i As Long
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set wb = ThisWorkbook
'lets suppose your data is in the first worksheet of your book
With wb
LastRow = .Sheets(1).Cells(.Sheets(1).Rows.Count, 1).End(xlUp).Row - 5 'this is to count how many rows you've got
Set Headers = .Sheets(1).Rows("1:5") 'set the headers to copy them every iteration
End With
'copy each row + headers in a new workbook
For i = 1 To LastRow
FileNm = wb.Path & "\" & "TEST-BOOK" & i & ".xlsx" 'add the i to number every workbook from 1 to extra rows you have
Set wbTemp = Workbooks.Add 'add a new workbook
Headers.Copy
wbTemp.Sheets(1).Rows(1).PasteSpecial xlPasteValues 'paste the headers
wb.Sheets(1).Rows(5 + i).Copy
wbTemp.Sheets(1).Rows(6).PasteSpecial xlPasteValues 'copy the next row in the iteration
wbTemp.SaveAs FileNm
wbTemp.Close
Set wbTemp = Nothing
Next i
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I have workbook and there many sheets i want to copy one by one sheets to new work book and rename workbook
I tried, but it saved in one workbook instead of separate workbooks also I don't want to copy first worksheet to copy new workbook
Option Explicit
Sub CreateWorkBooks()
Dim ws As Object
Dim i As Long
Dim ws_num As Integer
Application.ScreenUpdating = False
Set ws = Worksheets
ws_num = ThisWorkbook.Worksheets.Count
For i = 2 To ws_num
'Copy one worksheet as a new workbook
'The new workbook becomes the ActiveWorkbook
ws.Copy
'Replace all formulas with values (optional)
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
'May want (not required) to add a file name extension (.xls or .xlsx) to the file name
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & _
"AR Balance- " & ActiveSheet.Name & " " & Worksheets("DATA Sheet").Range("m2") & ".xlsx"
ActiveWorkbook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
End Sub
Welcome to SO. Only simple self explanatory corrections made. Try
Option Explicit
Sub CreateWorkBooks()
Dim ws As Worksheet ' Worksheets instead of Object
Dim i As Long
Dim ws_num As Integer
'Application.ScreenUpdating = False
ws_num = ThisWorkbook.Worksheets.Count
For i = 2 To ws_num
Set ws = ThisWorkbook.Worksheets(i) 'set ws to each sheet in the workbook
'Copy one worksheet as a new workbook
'The new workbook becomes the ActiveWorkbook
ws.Copy
'Replace all formulas with values (optional)
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
'May want (not required) to add a file name extension (.xls or .xlsx) to the file name
' Thisworkbook is to be added to refer Worksheets("DATA Sheet").Range("m2").Value
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & _
"AR Balance- " & ActiveSheet.Name & " " & ThisWorkbook.Worksheets("DATA Sheet").Range("m2").Value & ".xlsx"
ActiveWorkbook.Close False
Next
'Application.ScreenUpdating = True
End Sub