Copy values of a worksheet to a new workbook - vba

I'm trying to do something that seems simple, but keeps on causing me trouble.
Copying the active worksheet into a new workbook without formulas.
I've tried my luck with the following code:
Sub test()
ActiveSheet.Copy
With ActiveSheet.UsedRange
.Value = .Value
End With
End Sub
But that is quite unreliable, as it sometimes doesn't copy fields that clearly has a value.
I have cells that needs to have text that is both bold and normal and different sizes in the same damn cell.
The aforementioned method does not keep that formatting.
What I am currently doing looks like this:
Sub EksporterExcel()
Dim ws As Worksheet
Dim wb As Workbook
Dim tid As String
Set ws = Sheets(ActiveSheet.Name)
tid = Format(CStr(Now), "hh.mm.ss")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ws.Copy
Set wb = Workbooks(ActiveWorkbook.Name)
ws.UsedRange.Copy
wb.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
ActiveWorkbook.SaveAs _
FileFormat:=51, _
Filename:=Application.ThisWorkbook.Path & "\Udfyldte Indleveringsplaner\Excel\" & Date & "\" & ActiveSheet.Name & " Kl. " & tid & ".xlsx"
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
And that works.
It is however slow. Very, very slow. I'm assuming that this has to do with copying the sheet first and the going back to copy the cell values, so I'd like a way to avoid that.
This way also doesn't keep the formatting in the single cells that has multiple formatting options. That's low priority however.
I would love to know if there's a more efficient way to do this.
Below is an example of the result when using the first snippet of code, or the code in the answer by jkpieterse.
The original sheet before being copied.
The copied sheet
Some of the data is clearly lost after being copied

What about this version (also tidied up some of your code):
Sub EksporterExcel()
Dim tid As String
tid = Format(CStr(Now), "hh.mm.ss")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveSheet.Copy
ActiveSheet.UsedRange.Value2 = ActiveSheet.UsedRange.Value2
ActiveWorkbook.SaveAs _
FileFormat:=51, _
Filename:=Application.ThisWorkbook.Path & "\Udfyldte Indleveringsplaner\Excel\" & Date & "\" & ActiveSheet.Name & " Kl. " & tid & ".xlsx"
'Assume it is the active workbook you wanted to close...
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Related

VBA Save as CSV is garbling my data types

having a bit of an infuriating time dealing with Excel 2013 and I can't seem to find any answers which give me what I need.
I've written some simple VBA which generates a number of dummy data tables, the output is generating absolutely fine, and the formats appear to be correct in the output table prior to export.
However, the element that I'm having difficulty with is when I export the files using VBA into CSV (they need to be uploaded into SQL Server). The export itself works fine, but when I try to re-open the file in Excel the data types in my date columns are 'garbled'. I'm in the UK, and computer is set up as such, but Excel appears to be converting these to a US format, meaning that some are 'date' (any string which would fit a UK format), others are 'general' which would obviously cause issues when uploading to SQL Server.
I've tried manually copying the data tabs, and saving them as CSV. When I do this, I can open them and the date format is absolutely fine. I can only assume therefore that it's something to do with my export, any thoughts would be greatly appreciated.
Code is as below:
Sub exportdata()
wdir = ThisWorkbook.Path
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Save sheets which aren't the command sheet.
For Each sht In ThisWorkbook.Sheets
If sht.Name <> "Command" Then
Application.StatusBar = "Exporting sheet " & sht.Name
sht.Copy
Application.ActiveWorkbook.SaveAs wdir & "\Generated\" & sht.Name & ".csv", xlCSVWindows
Application.ActiveWorkbook.Close False
End If
Next
Application.StatusBar = ""
Does anybody have any ideas? Appreciate I can just manually export each tab, but that's incredibly annoying and I'll be needing to run this quite a few times.
Note - I've tried using xlCsv and xlCsvWindows, and the same thing happens.
I encountered the same issue.
The only way I know to avoid this is to open Excel and open the file from Excel.
When the file is opened a screen is popping up and Excel wants to know from the user how the data needs to be opened.
What I usually do is in the 3 screen to select all column and define them as text. This also prevents you from losing leading zero's (if applicable). This way in Excel numbers are as text (you can't calculate with them, but SAP for example doesn't mind to upload numbers as text. :) )
How about looping through your date range before saving as CSV, such as below:
Sub exportdata()
Dim c As Range
Dim sht As Worksheet
Dim LastRow As Long
wdir = ThisWorkbook.Path
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Save sheets which aren't the command sheet.
For Each sht In ThisWorkbook.Sheets
If sht.Name <> "Command" Then
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
For Each c In sht.Range("A1:A" & LastRow) 'loop through column A to format dates
c.Value = Format(c, "dd/mm/yyyy")
Next c
Application.StatusBar = "Exporting sheet " & sht.Name
'sht.Copy
Application.ActiveWorkbook.SaveAs wdir & "\Generated\" & sht.Name & ".csv", xlCSVWindows
Application.ActiveWorkbook.Close False
End If
Next
Application.StatusBar = ""
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have no idea if this will work (and can't test it because I live in the US), but one idea is to Copy/PasteSpecial the values in each sheet rather than copying the sheets directly.
Sub exportData()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If Not ws.Name = "Command" Then
Application.StatusBar = "Exporting sheet " & ws.Name
Call createTextFile(ws.UsedRange, ws.Parent.Path & "\Generated\", ws.Name & ".csv", xlCSV)
End If
Next
Application.StatusBar = ""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub createTextFile(sourceRng As Range, fPath As String, fName As String, fFormat As Variant)
Dim wb As Workbook
Set wb = Workbooks.Add
sourceRng.Copy
With wb.Sheets(1)
.Range(.Cells(1, 1), .Cells(sourceRng.Rows.Count, sourceRng.Columns.Count)).PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats
End With
Application.CutCopyMode = False
wb.SaveAs Filename:=fPath & fName, FileFormat:=fFormat
wb.Close
End Sub
If that doesn't work, I'd be curious to see if the issue is only with files with the .csv extension; you could test a .txt file by changing this line:
Call createTextFile(ws.UsedRange, ws.Parent.Path & "\Generated\", ws.Name & ".csv", xlCSV)
To this one:
Call createTextFile(ws.UsedRange, ws.Parent.Path & "\Generated\", ws.Name & ".txt", xlText)
As a last resort, you may be able to separate the day/month/year into separate columns, then modify your SQL script to combine them as it updates the tables. Something like this:
CREATE TABLE #temptbl
(
dtyear int,
dtmonth int,
dtday int,
dtdate AS (DATEFROMPARTS(dtyear, dtmonth, dtday)),
empid varchar(8),
hrsworked int
);
BULK INSERT #temptbl
FROM '\\yourpath\uploadfile.txt'
WITH
(
FIELDTERMINATOR = '\t',
ROWTERMINATOR = '\n'
);
MERGE dbo.emphours AS target
USING #temptbl AS source
ON
(target.empid = source.empid) AND
(target.dtdate = source.dtdate)
WHEN MATCHED AND (target.hrsworked <> source.hrsworked) THEN
UPDATE SET
target.hrsworked = source.hrsworked
WHEN NOT MATCHED BY target THEN
INSERT
(dtdate,empid,hrsworked)
VALUES
(source.dtdate,source.empid,source.hrsworked);
DROP TABLE #tempHH;

Code to merge data in multiple documents by column

Is there a way to merge the data in multiple excel spreadsheets together by column?
I have 200 spreadsheets, each with text in the first 100 columns (A-CV).
I would like to merge all the "A" columns from these 200 documents together, all the "B" columns together, all the "C" columns together, and so on.
As for the merging, no particular order is required. As long as the cells themselves don't get merged.
Due to the large amount of text the code would be merging, it would be more practical to be able to merge one column at a time across all spreadsheets into a unique file, then repeat that with all other columns (A-CV), instead of attempting to merge all the columns (from all spreadsheets) together into one single file.
I found a code that merges columns, but it's not quite what I need. Is there a way to modify this code to help with what I described above?
Sub Macro1()
'
' Macro1 Macro
'
Dim cell As Range
For i = 1 To 50
Sheets("Sheet1").Select
If Cells(1, i).Value = "Cat 2" Then
Columns(i).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
End If
If Cells(1, i).Value = "Cat 6" Then
Columns(i).Select
Selection.Copy
Sheets("Sheet2").Select
Range("B1").Select
ActiveSheet.Paste
End If
If Cells(1, i).Value = "Cat 4" Then
Columns(i).Select
Selection.Copy
Sheets("Sheet2").Select
Range("C1").Select
ActiveSheet.Paste
End If
Next i
End Sub
If you need more information, please let me know. And if I need to rename the documents a certain way to help with the process, I'm definitely willing to do that.
The merged data can be sent to a spreadsheet, word document, or notepad. I'm fine with any of these options.
UPDATE: This is the new code with modifications. The issues I am having are in the comment below.
Sub copydocument()
Dim wb As Workbook
Dim wb1 As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo resetsettings
Set wb = ThisWorkbook
MyPath = "C:\Users\HNR\Desktop\A\" 'Path of folder with \ at the end
MyExtension = "*.xlsx"
Myfile = Dir(MyPath & MyExtension)
While Myfile <> vbNullString
Set wb1 = Workbooks.Open(MyPath & Myfile)
lr = wb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
lr1 = wb1.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
wb1.Sheets(1).Range("A" & lr1).Copy Destination:=wb.Sheets(1).Range("A" & (lr + 1))
wb1.Close
Myfile = Dir
Wend
resetsettings:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
While there are many ways to do what you want, I would recommend looking into Power Query. It gives you a great GUI to work with to accomplish this. Depending on your version of excel it is either a free add-on or part of the shipped product(for new versions of office).
You do not need to know how to code to use this, you just need to understand the concepts.
While its not exactly the answer you are after i have successfully taught several people at my work place how to use this application that would have previously been reliant on me or someone else with VBA skills.
Sub copydocument()
Dim wb As Workbook
Dim wb1 As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo resetsettings
Set wb = ThisWorkbook
MyPath = "c:\Users\foo\" 'Path of folder with \ at the end
MyExtension = "*.xlsx"
Myfile = Dir(MyPath & MyExtension)
While Myfile <> vbNullString
Set wb1 = Workbooks.Open(MyPath & Myfile)
lr = wb.Sheets(1).Range("A1:A" & Rows.Count).End(xlUp).Row
lr1 = wb1.Sheets(1).Range("A1:A" & Rows.Count).End(xlUp).Row
wb1.Sheets(1).Range("A1:CV" & lr1).Copy Destination:=wb.Sheets(1).Range("A" & (lr + 1))
wb1.close
Myfile = Dir
Wend
resetsettings:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This macro will go through all the files in the folder and copy the sheet1 range and paste it in the active workbook sheet1. if you have headers and dont want them to repeat you can copy the header to the sheet1 of activeworkbook then copy range from (A2:CV &lr1).

Copy formulas without a cell reference change

I want to open a workbook and then copy a column to another workbook side by side (column from each file adjacent to each other).
However I do not want to change the cell reference (i.e. if refrence in range being copied is C15:C17 i do not want it to move). How could I approach this?
Currently I am using the following code:
Sub dane_wolne()
'Application.DisplayAlerts = False
'Application.ScreenUpdating = False
Application.Calculation = xlManual
Wiersz2 = 20
For i = 1 To Wiersz2
Workbooks.Open FileName:=Katalog & "U" & i & ".xlsx", ReadOnly:=True
Range("D11:D210").Copy
ThisWorkbook.Worksheets("Obliczenia").Range("E11:E210").Offset(0, i).PasteSpecial xlPasteFormulas
Workbooks("U" & i & ".xlsx").Close
Next i
'Application.DisplayAlerts = True
'Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
Range.Formula property
You can use:
ThisWorkbook.Worksheets("Obliczenia").Range("E11:E210").Offset(0, i).Formula = Range("D11:D210").Formula
Copy formats in separate step.
Off topic tips
Make the ThisWorkbook.Worksheets("Obliczenia").Range("E11:E210") a range variable once, then apply just .Offset to make your code a bit cleaner and faster (nanoseconds :))
Aslo, it is a good practice to set the new opened workbook into a variable, to make it more explicit and reliable. E.g.: Set SourceWB = Workbooks.Open FileName:=Katalog & "U" & i & ".xlsx", ReadOnly:=True (Not always necessary.)
Then use the SourceWB.Range("D11:D210")

Delete specific sheets from Workbook

I am trying to create a duplicate button on the excel ribbon which when clicked, will create a duplicate file of the active workbook but I want it to create a duplicate file having only first two sheets copied in the duplicate file and not the whole active workbook.
I tried the below code for getting the duplicate file :
Sub DupliquerFeuille(control As IRibbonControl)
Dim Sourcewb As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the sheet to a new workbook
nom = Day(Date) & "-" & Month(Date) & "-" & Year(Date) & "_" & ActiveWorkbook.Name
ActiveWorkbook.SaveCopyAs ActiveWorkbook.Path & "\" & nom
' ActiveWorkbook.Sheets(Array(1, 2)).Copy
End Sub
But I am getting all sheets of active workbook copied in the duplicate file. Can anyone please help me in getting only the first sheets of active workbook copied in the duplicate file. I tried a lot but I am unable to get the result.
Try this:
Sub DupliquerFeuille(control As IRibbonControl)
Dim twb As Workbook
Dim Sourcewb As Workbook
Const shc As Long = 2 ' change this as you need, this will copy first 2 sheets
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
Sourcewb.Sheets(1).Copy
Set twb = ActiveWorkbook
For i = 2 To shc
Sourcewb.Sheets(i).Copy ,twb.Sheets(twb.Sheets.Count)
Next
nom = Day(Date) & "-" & Month(Date) & "-" & Year(Date) & "_" & Sourcewb.Name
twb.SaveAs Sourcewb.Path & "\" & nom, Sourcewb.FileFormat
twb.Close False
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
How about just adding an extra few lines of code after you save the new workbook to delete out those pages you don't like?
Such as
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True
Replace "Sheet 1" with the name of the sheet (keep the quotation marks)
Below code lines find the path and name of current excel file, copy the first two sheets and save to a new (duplicated) workbook in the same location as the main workbook:
Set Sourcewb = ActiveWorkbook
' Create path and name for export
PathName = ThisWorkbook.Path & "_export"
' Copy the sheets so they don't get removed in the main file
Sheets(Array(1, 2)).Copy Before:=Sheets(1)
' Move the first two sheets to a new workbook
Sheets(Array(1, 2)).Move
' Save the active duplicated workbook
ActiveWorkbook.SaveAs Filename:=PathName, FileFormat:=Sourcewb.FileFormat
' Close the active duplicated workbook
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True

ActiveSheet.SaveAs only saves first worksheet - multiple times, but only on some machines

The following VBA snippet works correctly on one machine with Excel version
"Microsoft(R) Office Excel(R) 2007 (12.0.6727.5000) SP3 MSO (12.0.6728.5000)"
but not on one with
"Microsoft(R) Office Excel(R) 2007 (12.0.6729.5000) SP3 MSO (12.0.6728.5000)"
Breaking and single-stepping indicates that the wSheet is iterating over the known worksheets, but the exported files only contain the contents of the first worksheet - i.e. sheet1.csv, sheet2.csv, sheet3.csv are all saved, but each one contains the contents of sheet1 from the workbook.
A separate "macro" that only saves the active worksheet behaves identically - no matter which worksheet is active at the time the "macro" is invoked, only the data from the first worksheet is saved, though into a file named as the active worksheet. The DBPrint statement also shows that the wSheet is iterating over the worksheets. (DBPrint is just a Debug.Print with an on/off switch.)
For Each wSheet In ActiveWorkbook.Worksheets
wSheet.Activate
wSheetName = wSheet.Name
SaveAsName = wBookName & "." & wSheetName & ".csv"
DBPrint "saving as " & SaveAsName
On Error Resume Next
wSheet.SaveAs filename:=SaveAsName, FileFormat:=xlCSV
' ... error handling code (no errors reported, though)
On Error GoTo 0
Next wSheet
My workaround:
Dim Workbook1 As Workbook
Set Workbook1 = ActiveWorkbook
For Each wSheet In Workbook1.Sheets
SaveAsName = wBookName & "." & wSheet.Name & ".csv"
DBPrint "saving as " & SaveAsName
wSheet.Copy After:=Workbook1.Sheets(Workbook1.Sheets.Count)
Workbook1.Sheets(Workbook1.Sheets.Count).Move
ActiveWorkbook.SaveAs filename:=SaveAsName, FileFormat:=xlCSV
ActiveWorkbook.Close False
Next wSheet
Try that and let me know if it works.
I had the same problem and, for a while, used #puzzlepiece's workaround. It worked well but became a bit slow as the datasets I have to use became bigger.
Luckily, I found a fix that does not require copying and moving: https://www.extendoffice.com/documents/excel/628-excel-split-workbook.html
Sub Splitbook()
'Updateby20140612
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