My current vba code copies data from one sheet of my current and creates a new workbook with the data from that sheet.
Sub copying_data()
Dim FilePath As String: FilePath = ThisWorkbook.Path & "\"
Dim FName As String
FName = FilePath & "Summary_Output_" & _
Format(Date, "ddmmmyyyy") & ".xlsx"
ThisWorkbook.Sheets("AA_New").Copy
ActiveWindow.DisplayGridlines = False
ActiveWindow.Zoom = 110
ActiveWindow.Zoom = 120
Set NewBook = ActiveWorkbook
NewBook.SaveAs Filename:=FName
End Sub
This is currently working fine, but when it pastes the data it links it to the old sheet, instead I want it to paste the data as value but keeping the same formatting, is there any way to do this?
Add the file first then copy and paste special the values and formatting into the new sheet:
Sub copying_data()
Dim FilePath As String
FilePath = ThisWorkbook.Path & "\"
Dim FName As String
FName = FilePath & "Summary_Output_" & _
Format(Date, "ddmmmyyyy") & ".xlsx"
Dim swb As Workbook
Set swb = ThisWorkbook
Dim twb As Workbook
Set twb = Workbooks.Add
swb.Worksheets("AA_New").UsedRange.Copy
With twb.Worksheets(1).Range("A1")
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
twb.Worksheets(1).Name = "AA_New"
twb.SaveAs Filename:=FName
End Sub
Just small variations to Scott's answer which is perfectly valid.
Variable names conventions
Defining the file name in a different variable to use it in other steps
Windows adjustments you had in your code
Public Sub copying_data()
Dim newBook As Workbook
Dim filePath As String
Dim fileName As String
Dim fileFullPath As String
' Build the path
filePath = ThisWorkbook.Path & "\"
fileName = "Summary_Output_" & _
Format(Date, "ddmmmyyyy") & ".xlsx"
fileFullPath = filePath & fileName
' Add a new workbook
Set newBook = Workbooks.Add
' Save it with the path built
newBook.SaveAs fileFullPath
' Copy the sheet
ThisWorkbook.Sheets("AA_New").Copy Before:=Workbooks(fileName).Sheets(1)
' Copy/paste values
newBook.Sheets("AA_New").UsedRange.Copy
newBook.Sheets("AA_New").UsedRange.PasteSpecial xlPasteValues
newBook.Sheets("AA_New").UsedRange.PasteSpecial xlPasteFormats
' Adjust the window
Windows(fileName).DisplayGridlines = False
Windows(fileName).Zoom = 110
Windows(fileName).Zoom = 120
End Sub
Related
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
I'm relatively new to VBA. I worked on the following code, which workED perfectly until I decided to filter for non-blanks before saving the sheet.
The idea is to save my sheet in the same path after filtering out any blank values. The new file will be values only in CSV. Again, all of that worked, except when it comes to filtering the data and saving the file.
Now I get the
"Run-time error 438 Object doesn’t support this property or method"
on the code below
ThisWorkbook.Sheets("SHEET1").SpecialCells(xlCellTypeVisible).Copy
The full code
Private Sub CommandButton1_Click()
If Sheets("SHEET1").AutoFilterMode Then Sheets("SHEET1").AutoFilterMode = False
sDate = Format(Sheets("SHEET2").Range("F1"), "YYYY.MM.DD")
cell = "NAME - " & sDate
ThisWorkbook.Sheets("SHEET1").Range("A:C").AutoFilter Field:=2, Criteria1:="<>"
ThisWorkbook.Sheets("SHEET1").SpecialCells(xlCellTypeVisible).Copy
With ActiveSheet.UsedRange
.Value = .Value
End With
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & cell & ".csv", FileFormat:=xlCSV
End Sub
Please read the code's comments and adjust it to fit your needs
EDIT: Adjusted a type in this row sourceSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(targetWorkbook.Sheets.Count).Range("A1")
Private Sub CommandButton1_Click()
Dim targetWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim formatDate As String
Dim fileName As String
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
' Remove filter
If sourceSheet.AutoFilterMode Then sourceSheet.AutoFilterMode = False
If sourceSheet.Range("F1").Value <> vbNullString Then
formatDate = Format(sourceSheet.Range("F1").Value, "YYYY.MM.DD")
End If
' Set the new workbook file name
fileName = "NAME - " & formatDate
' Filter the fileNames
sourceSheet.Range("A:C").AutoFilter Field:=2, Criteria1:="<>"
' Add new workbook and set reference
Set targetWorkbook = Workbooks.Add
' Copy the visible fileNames in a new workbook
sourceSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(targetWorkbook.Sheets.Count).Range("A1")
' Save the new workbook
targetWorkbook.SaveAs ThisWorkbook.Path & "\" & fileName & ".csv", FileFormat:=xlCSV
End Sub
Let me know if it works
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
I am using VBA to loop through a specified directory, open excel workbooks that exist in the directory, copy a range from a worksheet and paste the contents to a new workbook.
In the new workbook, I want to add a hyperlink to the workbook that was copied.
Here is the code I am using to open, copy, and paste.
How can I add a hyperlink to the "StrFile" in the last column of my new workbook?
code
Private Sub LoopThroughFiles()
Dim x As Workbook
Dim y As Workbook
' Create new workbook, name file, name sheets, set target directory
Set NewBook = Workbooks.Add
With NewBook
.SaveAs Filename:="C:\NewFileName" _
& Format(Date, "yyyymmdd") & ".xlsx"
NewBook.Sheets("Sheet1").Name = ("NewSheet")
End With
Dim dirName As String
' this is the directory to open files from
dirName = ("C:\TargetDirectory\")
Dim StrFile As String
StrFile = Dir(dirName & "*.*")
Do While Len(StrFile) > 0
If Right(StrFile, 4) = "xlsx" Then ' Filter for excel files
Workbooks.Open (dirName & StrFile) ' Open the workbook
Worksheets("TargetSheet").Range("A2:AA2").Copy ' Copy paste to new book
NewBook.Sheets("NewSheet").Columns("A").Find("", Cells(Rows.Count, "A")).PasteSpecial (xlPasteValuesAndNumberFormats)
Application.DisplayAlerts = False
Workbooks(StrFile).Close False ' Close target workbook without saving
Application.DisplayAlerts = True
End If
StrFile = Dir
Loop
End Sub
Something like this
I have used my code from Loop through files in a folder using VBA? to work with the xlsx files directly.
Also I have improved the use of variables to handle the workbooks you are working with
The code would also beenfit from error handling (ie if Target Sheet wasn't present etc)
Private Sub LoopThroughFiles()
Dim NewBook As Workbook
Dim WB As Workbook
Dim rng1 As Range
' Create new workbook, name file, name sheets, set target directory
Set NewBook = Workbooks.Add
With NewBook
.SaveAs Filename:="C:\temp\file" _
& Format(Date, "yyyymmdd") & ".xlsx"
.Sheets(1).Name = ("NewSheet")
End With
Dim dirName As String
' this is the directory to open files from
dirName = ("C:\temp\")
Dim StrFile As String
StrFile = Dir(dirName & "*.xlsx")
Application.DisplayAlerts = False
Do While Len(StrFile) > 0
Set WB = Workbooks.Open(dirName & StrFile) ' Open the workbook
WB.Worksheets("TargetSheet").Range("A2:AA2").Copy ' Copy paste to new book
Set rng1 = NewBook.Sheets("NewSheet").Columns("A").Find("", Cells(Rows.Count, "A"))
rng1.PasteSpecial xlPasteValuesAndNumberFormats
NewBook.Sheets(1).Hyperlinks.Add NewBook.Sheets(1).Cells(rng1.Row, "AB"), dirName & StrFile, dirName & StrFile
WB.Close False ' Close target workbook without saving
StrFile = Dir
Loop
Application.DisplayAlerts = True
End Sub
I pieced together an Excel VBA script that writes all worksheets in an open workbook to separate, tab-delimited files (is this still a "macro"? I'm learning this in an Excel vacuum). It works well on one workbook at a time. Here it is.
Sub exportSheetsToText()
Dim sWb As String
Dim sFile As String
Dim oSheet As Worksheet
sWb = Left(ActiveWorkbook.FullName, InStr(ActiveWorkbook.FullName, ".") - 1)
For Each oSheet In Worksheets
oSheet.Copy
sFile = sWb & "-" & oSheet.Name & ".txt"
ActiveWorkbook.SaveAs fileName:=sFile, FileFormat:=xlText
ActiveWorkbook.Close SaveChanges:=False
Next oSheet
End Sub
I would like to scale this up so that I can apply this macro to a folder of workbooks. I wrote what I thought would loop over every workbook that satisfies the filter, but it doesn't write any of the .txt files. Here it is.
Sub exportsSheetsToTextForAll()
Dim sPath As String
Dim sWildcard As String
Dim sMacro As String
Dim oWb As Workbook
Dim oPersWb As Workbook
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Set oPersWb = Workbooks("PERSONAL.XLSB")
sMacro = "'" & oPersWb.Name & "'" & "!exportSheetsToText()"
sPath = "C:\Users\richard\Documents\Research\Data\Excel\Datastream - payout"
sWildcard = "New*.xlsx"
sFile = Dir(sPath & "\" & sWildcard)
Do While Len(sFile) > 0
Workbooks.Open Filename:=sPath & "\" & sFile
Application.Run sMacro
ActiveWorkbook.Close SaveChanges:=False
sFile = Dir
Loop
End Sub
It loops through all of my test files, but I don't see any effects (i.e., no .txt files and no errors).
Eventually I will run this on very large workbooks with macros, so it is important to disable the macros (I don't have the macros locally, they're on a dedicated data machine) and close one large workbook before opening the next.
Any ideas? Thanks!
#Siddarth's idea of passing an argument to exportSheetsToText() was the key. As well I had an error with macro name passed to Application.Run. The following works and is much cleaner.
Sub exportsSheetsToTextForAll()
Application.AutomationSecurity = msoAutomationSecurityForceDisable
excelFiles = Dir(ThisWorkbook.Path & "\" & "New*.xlsx")
fromPath = ThisWorkbook.Path
Do While Len(excelFiles) > 0
Debug.Print Files
Set oWb = Workbooks.Open(Filename:=fromPath & "\" & excelFiles)
Application.Run "exportSheetsToText", oWb
oWb.Close SaveChanges:=False
excelFiles = Dir
Loop
End Sub
Sub exportSheetsToText(iWb As Workbook)
For Each ws In iWb.Worksheets
ws.Copy
Set wb = ActiveWorkbook
textFile = Left(iWb.FullName, InStr(iWb.FullName, ".") - 1) & "-" & ws.Name & ".txt"
wb.SaveAs Filename:=textFile, FileFormat:=xlText
wb.Close SaveChanges:=False
Next ws
End Sub