Good day, I have about 125 spreadsheets in a folder and want to consolidate all the data, that I put onto one sheet for each file, from all the spreadsheets onto a different workbook. I have a loop through files in folder but it pastes the formula and not the actual values. How could I do this with the below code? I have searched through the site and anything that looks like it could work causes an error. Any help with this would be much appreciated.
Sub LoopThroughFilesInFolder()
Dim mainwb As Workbook
Dim wb As Workbook
Dim i As Integer
Set mainwb = ThisWorkbook
mainwb.Activate
Sheets("Engine").Select
Range("a2:c500").ClearComments
Set FileSystemObj = CreateObject("Scripting.FileSystemObject")
Set FolderObj = FileSystemObj.GetFolder("C:\Desktop\Vessel folder 2016") 'Use path of the folder
For Each fileobj In FolderObj.Files 'loop through the files
If fileobj.Name <> "Bronco.xlsm" And fileobj.Name <> "~$Bronco.xlsm" And (FileSystemObj.GetExtensionName(fileobj.Path) = "xlsx" Or FileSystemObj.GetExtensionName(fileobj.Path) = "xlsm") Then
Application.DisplayAlerts = False
Set wb = Workbooks.Open(fileobj.Path)
'copy the results from the just opened wb
wb.Worksheets("ZenGarden").Select
lastcell = Range("a2:EQ5").SpecialCells(xlCellTypeLastCell).Address
Range("a2:" & lastcell).Select
Selection.Copy
'go to the mainworkbook and paste data
mainwb.Activate
Sheets("Engine").Select
If Range("a2").Value = "" Then
Range("a2").Select
Else
Range("a1").End(xlDown).Offset(1, 0).Select
End If
ActiveSheet.Paste
wb.Activate
wb.Save
wb.Close
mainwb.Activate
End If
Next fileobj
End Sub
Use Range.PasteSpecial xlPasteValues, for example:
'Copy the range into Clipboard
wb.Sheets(1).Range("A4").CurrentRegion.Copy
'Setup target range to paste Clipboard values
Dim targetRange As Range
Set targetRange = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Offset(1, 0)
'Paste Values into target range
targetRange.PasteSpecial xlPasteValues
So in your case it would look something like:
'copy the results from the just opened wb
wb.Worksheets("ZenGarden").Select
lastcell = Range("a2:EQ5").SpecialCells(xlCellTypeLastCell).Address
Range("a2:" & lastcell).Select
Selection.Copy
'go to the mainworkbook and paste data
mainwb.Activate
Dim targetSheet as Sheet
Set targetSheet = Sheets("Engine")
Dim targetRange As Range
Set targetRange = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Offset(1, 0)
'Paste Values into target range
targetRange.PasteSpecial xlPasteValues
Related
I am trying to create a loop to copy data in cells in source worksheet one by one and paste in a particular cell in target worksheet. Once the cell is pasted, i need it to save a copy of the file then paste the next value in the source worksheet.The code is:
Private Sub CommandButton1_Click()
Dim wbTarget As Worksheet
Dim wbSource As Worksheet
Dim SaveLoc As String
Dim FName As String
Dim i As Long
Set wbSource = Sheets("Sheet3")
Set wbTarget = Sheets("Sheet1")
wbSource.Activate
Range("A1").Activate
Do While ActiveCell.Value <> ""
DoEvents
ActiveCell.Copy
For i = 1 To 30
wbTarget.Activate
With ActiveSheet
wbTarget.Range("E5").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths
Selection.PasteSpecial Paste:=xlPasteValues
ThisWorkbook.Save
Application.CutCopyMode = False
End With
SaveLoc = "H:\Services\Test Output\Term_"
FName = Range("B5")
ActiveWorkbook.SaveCopyAs FileName:=SaveLoc & FName & ".xls" 'FileFormat:=xlNormal
Application.DisplayAlerts = False
Next i
wbSource.Select
ActiveCell.Offset(1, 0).Activate
Loop
Application.ScreenUpdating = True
End Sub
When I run this, I get a
run-time error 1004.
Please advise on how to resolve this.
Thank You in Advance.
Try the code below, without using Activate, ActiveCell, Select and Selection, instead use fully qualifies Ranges and Worksheet objects.
Explanation inside the code as comments (also some question about your code).
Code
Option Explicit
Private Sub CommandButton1_Click()
Dim wbTarget As Worksheet
Dim wbSource As Worksheet
Dim SaveLoc As String
Dim FName As String
Dim i As Long, lRow As Long
Set wbSource = Sheets("Sheet3")
Set wbTarget = Sheets("Sheet1")
' SaveLoc string never changes, doesn;t need to be set every time inside the loops
SaveLoc = "H:\Services\Test Output\Term_"
' you never qualifed the range with on of the worksheets (I'm guessing here it's "Sheet3"
FName = wbTarget.Range("B5").Value
Application.ScreenUpdating = False
lRow = 1
Do While wbSource.Range("A" & lRow).Value <> ""
wbSource.Range("A" & lRow).Copy
For i = 1 To 30
' 2 lines below you are pasting to cell "E5" don't you mean to increment with the row number (i variable)
wbTarget.Range("E5").PasteSpecial xlPasteValues
wbTarget.Range("E5").PasteSpecial xlPasteColumnWidths
ThisWorkbook.Save
Application.CutCopyMode = False
' have this line before trying to save a copy of this workbook
Application.DisplayAlerts = False
ThisWorkbook.SaveCopyAs Filename:=SaveLoc & FName & ".xls" 'FileFormat:=xlNormal
Application.DisplayAlerts = True
Next i
lRow = lRow + 1
Loop
Application.ScreenUpdating = True
End Sub
I wrote the following code to clean the workbook and then to create empty sheets
Sub conclusion()
Dim xWs As Worksheet
Dim Path As String, Filename As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Sheet1" And xWs.Name <> "Summary" Then
xWs.Delete
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' create new sheets
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Summary").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
' copy the workbooks into the sheets (My question )
End Sub
and then it should read the path from a cell in my case B2 and look for all xls files in this folder and copy to the crated sheets whose names are in
I wrote the following
Path= Sheets("Summary").Range("B2").Value ***( it does not read the value of B2, why? )***
Filename = Dir("Path" & "*.xls")
Do While Filename <> ""
***here is my question, how can I write the following:
COPY THE WORKBOOK 1 INTO SHEET with the name from Cell A2***
Loop
To fix the first problem try:
With Application.Workbooks("BookName").Sheets("Summary")
Path = .Range("B1").Text & "\" & .Range("A2").Text
End With
For the second your variable Path is in quotes which it shouldn't be as it is not a string but a string variable. Not too sure why you had the wildcard asterisk in there either...
Filename = Dir(Path & ".xls")
For the last part, your For Loop is missing what it is that you want to cycle through (ie. cells)
For Each MyCell In MyRange.Cells
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
how to merge content of two Excel file using VB macro Code .
Sub GetSheets()
Dim temp As String
Path = "C:\Users\....\ Desktop\Excel combine\"
Filename = Dir(Path & "*.xlsx")
Do While Filename "" Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
temp = ActiveWorkbook.Name ActiveSheet.Name = temp
ActiveWorkbook.Sheets(temp).Copy After:=ThisWorkbook.Sheets(1)
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
The code what i am getting online is not meeting the requirement.
Below Code will Copys Entire Sheet1 of WorkBook1 and places to WorkBook2 after Sheet1
Sub CopySheet_From_WB1_To_WB2()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set wb1 = Application.Workbooks.Open("C:\Users\...\Desktop\1.xlsx")
Set ws1 = wb1.Sheets("sheet1") 'replece 'Sheet1' with your sheet name
Set wb2 = Application.Workbooks.Open("C:\Users\...\Desktop\2.xlsx")
'Copying WorkBook1's Sheet1 to Workbook2 after Sheet1
ws1.Copy After:=wb2.Sheets("Sheet1") 'replece 'Sheet1' with your sheet name
wb1.Save
wb1.Close
wb2.Save
wb2.Close
End Sub
Below Code will copy used cells values from Sheet1 of Workbook1 and paste after last used row of Sheet1 of Workbook2
Sub CopySheet1Data_to_Sheet2()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set wb1 = Application.Workbooks.Open("C:\Users\...\Desktop\1.xlsx")
Set ws1 = wb1.Sheets("sheet1") 'replece 'Sheet1' with your sheet name
ws1.Range(Cells(1, 1), ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
Set wb2 = Application.Workbooks.Open("C:\Users\..\Desktop\2.xlsx")
Set ws2 = wb2.Sheets("Sheet1")
ws2.Activate
lastUsedRow = ActiveCell.SpecialCells(xlLastCell).Row
ws2.Cells(lastUsedRow + 1, 1).Select
ActiveSheet.Paste
wb1.Save
wb1.Close
wb2.Save
wb2.Close
End Sub
I am trying to combine multiple excel files into one file. I am able to do that correctly, but the location I want to place the data is running into a small problem.
I want my data to start (paste) at cell A2 under the header row, but since my sheet is formatted as a table with a named range, my data is pasted just below the last line of that blank table. This is the code I'm using to paste the data.
Sub CombineFiles()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer
ThisWB = ActiveWorkbook.Name
path = "C:\MyFolder"
RowofCopySheet = 2
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = ActiveWorkbook.Sheets("Import")
Range("A2").Select
Filename = Dir(path & "\*.xl??", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
Set Dest = shtDest.Range("A" & shtDest.Cells(Rows.Count, 1).End(xlUp).Row + 1)
CopyRng.Copy
Dest.PasteSpecial xlPasteFormats
Dest.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False 'Clear Clipboard
Wkb.Close False
End If
Filename = Dir()
Loop
Sheets("Import").Select
Range("A1").Select
End Sub
Is there any change I can make to the code or the contents of the cells in the table to allow this to work correctly? Thanks for the help!
Please try this after changing range to your requirements. It will paste from A2. Using the clipboard takes time and resources so the best way would be to avoid a copy and paste and just set the values equal to what you want.Though you have mentioned that data transfer is required between separate workbooks but mentioned code for only basic problem, so this code fragment conveys the basic concept for transfer in a situation where there is a named table involved.
Sub Normalize()
Dim CopyFrom As Range
Set CopyFrom = Sheets("Sheet2").Range("A2", [H30])
Sheets("Sheet1").Range("A1").Resize(CopyFrom.Rows.Count).Value = CopyFrom.Value
End Sub
I have an error message of 'Object Required' when I run this sub. I have a version for copying each specific sheet, which works fine, but this sub is for all sheets within the WB ie to copy each one's WholePrintArea and paste it into a new sheet in the new WB. Thanks...
Sub NewWBandPasteSpecialALLSheets()
MyBook = ActiveWorkbook.Name ' Get name of this book
Workbooks.Add ' Open a new workbook
NewBook = ActiveWorkbook.Name ' Save name of new book
Workbooks(MyBook).Activate ' Back to original book
Dim SH As Worksheet
For Each SH In MyBook.Worksheets
SH.Range("WholePrintArea").Copy
Workbooks(NewBook).Activate
With SH.Range("A1")
.PasteSpecial (xlPasteColumnWidths)
.PasteSpecial (xlFormats)
.PasteSpecial (xlValues)
End With
Next
End Sub
Try do something like this (the problem was that you trying to use MyBook.Worksheets, but MyBook is not a Workbook object, but string, containing workbook name. I've added new varible Set WB = ActiveWorkbook, so you can use WB.Worksheets instead MyBook.Worksheets):
Sub NewWBandPasteSpecialALLSheets()
MyBook = ActiveWorkbook.Name ' Get name of this book
Workbooks.Add ' Open a new workbook
NewBook = ActiveWorkbook.Name ' Save name of new book
Workbooks(MyBook).Activate ' Back to original book
Set WB = ActiveWorkbook
Dim SH As Worksheet
For Each SH In WB.Worksheets
SH.Range("WholePrintArea").Copy
Workbooks(NewBook).Activate
With SH.Range("A1")
.PasteSpecial (xlPasteColumnWidths)
.PasteSpecial (xlFormats)
.PasteSpecial (xlValues)
End With
Next
End Sub
But your code doesn't do what you want: it doesen't copy something to a new WB. So, the code below do it for you:
Sub NewWBandPasteSpecialALLSheets()
Dim wb As Workbook
Dim wbNew As Workbook
Dim sh As Worksheet
Dim shNew As Worksheet
Set wb = ThisWorkbook
Workbooks.Add ' Open a new workbook
Set wbNew = ActiveWorkbook
On Error Resume Next
For Each sh In wb.Worksheets
sh.Range("WholePrintArea").Copy
'add new sheet into new workbook with the same name
With wbNew.Worksheets
Set shNew = Nothing
Set shNew = .Item(sh.Name)
If shNew Is Nothing Then
.Add After:=.Item(.Count)
.Item(.Count).Name = sh.Name
Set shNew = .Item(.Count)
End If
End With
With shNew.Range("A1")
.PasteSpecial (xlPasteColumnWidths)
.PasteSpecial (xlFormats)
.PasteSpecial (xlValues)
End With
Next
End Sub
Rethink your approach. Why would you copy only part of the sheet? You are referring to a named range "WholePrintArea" which doesn't exist. Also you should never use activate, select, copy or paste in your script. These make the "script" vulnerable to user actions and other simultaneous executions. In worst case scenario data ends up in wrong hands.
This worked for me (I added an "if sheet visible" because in my case I wanted to skip hidden sheets)
Sub Create_new_file()
Application.DisplayAlerts = False
Dim wb As Workbook
Dim wbNew As Workbook
Dim sh As Worksheet
Dim shNew As Worksheet
Dim pname, parea As String
Set wb = ThisWorkbook
Workbooks.Add
Set wbNew = ActiveWorkbook
For Each sh In wb.Worksheets
pname = sh.Name
If sh.Visible = True Then
sh.Copy After:=wbNew.Sheets(Sheets.Count)
wbNew.Sheets(Sheets.Count).Cells.ClearContents
wbNew.Sheets(Sheets.Count).Cells.ClearFormats
wb.Sheets(sh.Name).Activate
Range(sh.PageSetup.PrintArea).Select
Selection.Copy
wbNew.Sheets(pname).Activate
Range("A1").Select
With Selection
.PasteSpecial (xlValues)
.PasteSpecial (xlFormats)
.PasteSpecial (xlPasteColumnWidths)
End With
ActiveSheet.Name = pname
End If
Next
wbNew.Sheets("Hoja1").Delete
Application.DisplayAlerts = True
End Sub
Since you are copying all worksheet, how about:
Copy & Paste (X)
SaveAS (O)
Sub Export()
Application.DisplayAlerts = False
On Error Resume Next
Dim NewWB As String
NewWB = Sheets("Control").Range("B42")
ActiveWorkbook.SaveAs Filename:=NewWB, FileFormat:=xlWorkbookNormal
ActiveWorkbook.Sheets("Control").Delete
End Sub
I had a worksheet "Control" handling all variant, you may change it yourself
On the other hand, if you really wish to use COPY & PASTE, you could use ARRAY
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=FolderPath & ExcelName & ".xlsx", FileFormat:=xlNormal
Workbooks(ExcelOrigin).Activate
Sheets(Array("for coversheet", "Pivot", "CCA", "FRR", "CRS", "GSA", "Inv Summary", "UploadtoJDE", "Comat")).Copy Before:=Workbooks(ExcelName).Sheets(1)
Sheets("Sheet1").Delete
Remember to Dim (FolderPath,ExcelName,ExcelOrigin) as String
As equal them to your file name & file path
[ i can't type in those here because of error ]