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")
Related
I found a website that has a macro that lets you complete a looped action for all spreadsheets in a file folder. I've used this macro as the basis for my macro below: See Link Here
I've been able to use it successfully for a few other projects, but I'm running into some issues on my current project. I have a number of spreadsheets in a file folder that I'm attempting to open, copy the data, then paste into a master spreadsheet. The goal is to put all the data from the many spreadsheets, into one singular spreadsheet. The list of the many spreadsheets in the file folder is a dynamic list that will change over time. So I can't simply individually reference every spreadsheet, that's why I'm trying to use the looping strategy from the link above.
The problem I'm having is some of the pastes are getting pasted over previous spreadsheet's values. So instead of each spreadsheet getting pasted at the bottom of the previous's values, some are getting pasted in the middle and overwriting information that I need. I think my problem is that excel is getting confused as to which spreadsheet should be referenced when I gets into the row.count, copy/paste section of the code and the variables for i & j are getting assigned incorrectly. But I can't figure out how to fix this. I'm out of ideas, and thoroughly frustrated! Apologies if I'm screwing up something rather basic, but I'm rather new to VBA.
Sub CombineReports()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim i As Integer
Dim j As Integer
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
myPath = "I:\Pricing\mt access\Tier Reports\Final Reports\"
'Target Path with Ending Extention
myFile = Dir(myPath)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Worksheet tasks
i = wb.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
wb.Worksheets(1).Range("A5", "N" & i).Copy
Workbooks.Open ("I:\Pricing\mt access\Tier Reports\Final Reports\Combined Report\CombinedTierReport.xlsx")
j = Workbooks("CombinedTierReport.xlsx").Worksheets("AllStores").Range("B" & Rows.Count).End(xlUp).Row
Workbooks("CombinedTierReport.xlsx").Worksheets("AllStores").Range("A" & j + 1, "N" & i).PasteSpecial xlPasteValues
Workbooks("CombinedTierReport.xlsx").Save
Workbooks("CombinedTierReport.xlsx").Close
DoEvents
'Save and Close Workbook
Application.DisplayAlerts = False
wb.Close SaveChanges:=False
Application.DisplayAlerts = True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Change Range("A" & j + 1, "N" & i) to Range("A" & j + 1). a) the range is wrong and b) you only need the top-left cell of a paste.
...
i = wb.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
wb.Worksheets(1).range("A5", "N" & i).Copy
with Workbooks.Open ("I:\Pricing\mt access\Tier Reports\Final Reports\Combined Report\CombinedTierReport.xlsx")
j = .Worksheets("AllStores").Range("B" & Rows.Count).End(xlUp).Row
.Worksheets("AllStores").Range("A" & j + 1).PasteSpecial xlPasteValues
.Save
.Close savechanges:=false
end with
...
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
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).
I want to split workbook by worksheet name but if throws above error after splitting 5 sheets but i have 20 sheets in the workbook. I have used below code and the error happens at xWs.copy.
Please help me fix the error in the code. Thanks in advance.
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
I believe you have a hidden worksheet in the queue. In the following, I've stored the original Worksheet.Visible property value (XlSheetVisibility Enumeration), then made the worksheet visible and finally restored the original visiblility state. If it was already visible to begin with, there is no error.
I never recommend that you include a file extension in a Workbook.SaveAs operation. In fact, I recommend intentionally omitting it and allowing the FileFormat parameter and XlFileFormat Enumeration to supply the correct file extension.
Sub Splitbook()
Dim vis As Long, xPath As String, xWs As Worksheet
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
vis = xWs.Visible
xWs.Visible = xlSheetVisible
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name, _
FileFormat:=xlOpenXMLWorkbook
Application.ActiveWorkbook.Close False
xWs.Visible = vis
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
If you want to skip worksheets that are not visible, add a condition that does not perform the Copy, SaveAs operation if the xWs.Visible property is not xlSheetVisible.
If there is code in the worksheet code sheet (e.g. a Worksheet_Change event macro), it will be discarded without acknowledgement due to the Application.DisplayAlerts you have to False.
It looks like the workbook you are splitting gets activated, and because it contains macros it couldn't be saved as xlsx.
Try to add Application.EnableEvents = False before your For Each xWs In ThisWorkbook.Sheets and after the cycle Application.EnableEvents = True
I'm trying to programmatically copy a large range of cells from one workbook to another in VBA. I want to copy the formatting (including the entire source theme) and values, but NOT formulas. The following is my VBA code:
fromCells.Copy
toCells.PasteSpecial Paste:=xlPasteFormats
toCells.PasteSpecial Paste:=xlPasteColumnWidths
toCells.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Unfortunately, there are occasions when the above code doesn't work. This is usually with Font face and size. I noticed that whenever this happens, the only way to copy the font formatting across is to use xlPasteAllUsingSourceTheme, so it seems the font formatting is somehow registered to a 'source theme'. Unfortunately, xlPasteAllUsingSourceTheme doesn't work for me because it's copying formulas as well.
So is there a way to copy the source theme (formatting only) across? Or maybe a way to force copy all the font formatting across?
Note: Copying using xlPasteAllUsingSourceTheme and then overwriting it with xlPasteValues won't work for me because when the formulas is copied it keeps popping up message boxes telling me about issues with the formulas (such as conflicting named ranges used in the formulas, etc.).
I'm using Excel 2013. I noticed this problem doesn't seem to arise in Excel 2007 or earlier. Any help is appreciated.
Edit: I've also tried the following code (added to the beginning of the above code), it still doesn't work...
Dim themeTempFilePath As String
themeTempFilePath = Environ("temp") & "\" & fromWorkbook.Name & "Theme.xml"
fromWorkbook.Theme.ThemeFontScheme.Save themeTempFilePath
toWorkbook.Theme.ThemeFontScheme.Load themeTempFilePath
fromWorkbook.Theme.ThemeColorScheme.Save themeTempFilePath
toWorkbook.Theme.ThemeColorScheme.Load themeTempFilePath
Update: It seems the above code for saving and loading themes does work. The problematic text that I was looking at came from a different place - a form control. It was copied as a picture (using Shape.CopyPicture) but somehow the font gets changed in the process. However, I'll post this issue as another question.
For this question, I'll put up the theme saving and loading mechanism as an answer.
Try 1 or 2
Option Explicit
Public Sub copyWithoutFormulas_1()
xlEnabled False
With Sheet2
.EnableCalculation = False
.EnableFormatConditionsCalculation = False
.UsedRange.EntireColumn.Delete
Sheet1.UsedRange.Copy .Cells(1, 1)
.UsedRange.Value2 = .UsedRange.Value2
.EnableCalculation = True
.EnableFormatConditionsCalculation = True
End With
Application.CutCopyMode = False
xlEnabled True
End Sub
Public Sub copyWithoutFormulas_2()
xlEnabled False
Sheet1.Copy After:=Worksheets(Worksheets.Count)
With Worksheets(Worksheets.Count).UsedRange
.Value2 = .Value2
End With
xlEnabled True
End Sub
Private Sub xlEnabled(ByVal opt As Boolean)
With Application
.EnableEvents = opt
.DisplayAlerts = opt
.ScreenUpdating = opt
.Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub
To force copy the source theme to the destination cells, one can do the following. Unfortunately, this method will apply the source theme to the entire destination workbook, which is OK in my situation. Not sure if it's useful for anyone else.
Sub CopyText(fromCells As Range, toCells As Range, Optional copyTheme As Boolean = False)
If copyTheme Then
Dim fromWorkbook As Workbook
Dim toWorkbook As Workbook
Dim themeTempFilePath As String
Set fromWorkbook = fromCells.Worksheet.Parent
Set toWorkbook = toCells.Worksheet.Parent
themeTempFilePath = Environ("temp") & "\" & fromWorkbook.Name & "Theme.xml"
fromWorkbook.Theme.ThemeFontScheme.Save themeTempFilePath
toWorkbook.Theme.ThemeFontScheme.Load themeTempFilePath
fromWorkbook.Theme.ThemeColorScheme.Save themeTempFilePath
toWorkbook.Theme.ThemeColorScheme.Load themeTempFilePath
End If
Set toCells = toCells.Cells(1, 1).Resize(fromCells.Rows.Count, fromCells.Columns.Count)
fromCells.Copy
toCells.PasteSpecial Paste:=xlPasteFormats
toCells.PasteSpecial Paste:=xlPasteColumnWidths
toCells.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End Sub