Currently i'm trying to consolidate the information from 3000 different xls sheets into one file.
The master file looks like this
http://i.imgur.com/lQWxQxO.png
All the other excels are contained in 1 folder like this. They are only 1 sheet each.
http://i.imgur.com/VxmaLCf.png
and lastly would be that the information inside the files are like this
http:// i.imgur.com/w3erGgN.png
I'm trying to count the number of "pos", "neg" and "neu" inside the files and consolidate on the master sheet and the current way i'm doing is to manually input countif codes while leaving the document open. Is there any other way to make it faster? I've tried sumproduct but it never works. it only returns 0 as i think it might be the wildcard problem.
I think the following code could be of use to me but I'm not sure how to code it such that it works accordingly.
Sub RunCodeOnAllXLSFiles()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "C:\MyDocuments\TestResults"
.FileType = msoFileTypeExcelWorkbooks
'Optional filter with wildcard
'.Filename = "Book*.xls"
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
'DO YOUR CODE HERE
wbResults.Close SaveChanges:=False
Next lCount
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Please help.
Sub Merge()
Path = "C:\path to the folder\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
Found here: http://www.extendoffice.com/documents/excel/456-combine-multiple-workbooks.html
Related
I recently asked a question and received a great answer on this site, but I am now running into a different problem. The code below works well for running through each workbook in a folder, copying a sheet's contents, and pasting those contents into a master workbook exactly how I would like:
Sub ConslidateWorkbooks()
'Code to pull sheets from multiple Excel files in one file directory
'into master "Consolidation" sheet.
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Dim wbName As String
With ActiveSheet
Range("A1").Activate
End With
Application.ScreenUpdating = False
FolderPath = ActiveWorkbook.Path & "\"
Filename = Dir(FolderPath & "*.xls*")
wbName = ActiveWorkbook.Name
Do While Filename <> ""
If Filename <> wbName Then
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
copyOrRefreshSheet ThisWorkbook, Sheet
Next Sheet
Workbooks(Filename).Saved = True
Workbooks(Filename).Close
ActiveSheet.Range("A1").Activate
End If
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Sub copyOrRefreshSheet(destWb As Workbook, sourceWs As Worksheet)
Dim ws As Worksheet
On Error Resume Next
Set ws = destWb.Worksheets(sourceWs.Name)
On Error GoTo 0
If ws Is Nothing Then
sourceWs.Copy After:=destWb.Worksheets(destWb.Worksheets.Count)
Else
ws.Unprotect Password:="abc123"
ws.Cells.ClearContents
sourceWs.UsedRange.Copy
ws.Range(sourceWs.UsedRange.Address).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
End If
End Sub
The problem I am having now: After the paste is completed, each sheet in the master workbook has all of its cells selected, as though I Ctrl+A'd the entire sheet. I would like to get rid of this. It is a small task which I tried to accomplish in the line ActiveSheet.Range("A1").Activate within the Do While .. loop, but it has not worked for me.
EDIT:
I found a solution that works in this case. I am not sure why this was necessary, because the comments and answers in this thread seem like they should work, but they did not. I call this sub before I turn screenupdating to True in the main sub:
Sub selectA1()
Worksheets(1).Activate
Dim Sheet As Worksheet
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Activate
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
Sheet.Range("A1").Select
Next Sheet
Worksheets(1).Activate
End Sub
I realize this is more complicated than it should be, but it works for my purposes.
In your copy sub, add in another code in the loop that will select a cell which should deactivate the total used range selection and just select the coded range.
Sub copyOrRefreshSheet(destWb As Workbook, sourceWs As Worksheet)
Dim ws As Worksheet
On Error Resume Next
Set ws = destWb.Worksheets(sourceWs.Name)
On Error GoTo 0
If ws Is Nothing Then
sourceWs.Copy After:=destWb.Worksheets(destWb.Worksheets.Count)
Else
ws.Unprotect Password:="abc123"
ws.Cells.ClearContents
sourceWs.UsedRange.Copy
ws.Range(sourceWs.UsedRange.Address).PasteSpecial (xlPasteAll)
ws.range("A1").select
Application.CutCopyMode = False
End If
End Sub
I added ws.range("A1").select which should do as I described above.
I have files in a folder and I want to copy data from these files and paste them into another Master workbook sheet.
I keep getting a runtime error ‘1004’: Sorry we couldn’t find C:\Users\jjordan\Desktop\Test Dir\MASTER`, It is possible it was moved, renamed or deleted.
The error is highlighted on this line of code: Workbooks.Open SumPath & SumName
I have seen other questions similar to this on the web, I have tried making various changes. But still without success. Please advise.
Dir for source files: C:\Users\ jjordan \Desktop\Test Dir\GA Test\
Dir for Master file: C:\Users\ jjordan \Desktop\Test Dir\MASTER\
Source filenames differ, but all end in "*.xlsx."
Master filename: " MASTER – Data List - 2016.xlsm " ‘macro file
Source worksheet name = "Supplier_Comments"
Master worksheet name = "Sheet5"
Option Explicit
Sub GetDataFromMaster()
Dim MyPath As String
Dim SumPath As String
Dim MyName As String
Dim SumName As String
Dim MyTemplate As String
Dim SumTemplate As String
Dim myWS As Worksheet
Dim sumWS As Worksheet
'Define folders and filenames
MyPath = "C:\Users\jjordan\Desktop\Test Dir\GA Test\"
SumPath = "C:\Users\jjordan\Desktop\Test Dir\MASTER\"
MyTemplate = "*.xlsx" 'Set the template.
SumTemplate = "MASTER – Data List - 2016.xlsm"
'Open the template file and get the Worksheet to put the data into
SumName = Dir(SumPath & SumTemplate)
Workbooks.Open SumPath & SumName
Set sumWS = ActiveWorkbook.Worksheets("Sheet5")
'Open each source file, copying the data from each into the template file
MyName = Dir(MyPath & MyTemplate) 'Retrieve the first file
Do While MyName <> ""
'Open the source file and get the worksheet with the data we want.
Workbooks.Open MyPath & MyName
Set myWS = ActiveWorkbook.Worksheets("Suppliers_Comment")
'Copy the data from the source and paste at the end of sheet 5
myWS.Range("A2:N100").Copy
sumWS.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
'Close the current sourcefile and get the next
Workbooks(MyName).Close SaveChanges:=False 'close
MyName = Dir 'Get next file
Loop
'Now all sourcefiles are copied into the Template file. Close and save it
Workbooks(SumName).Close SaveChanges:=True
End Sub
Here is a template for what you'd like done. NOTE that forward slashes can cause run time error b/c vba handles them in an annoying way.
Sub DougsLoop()
Dim wbk As Workbook
Dim Filename As String
Dim path As String
Dim rCell As Range
Dim rRng As Range
Dim wsO As Worksheet
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim sheet As Worksheet
Application.ScreenUpdating = False 'these three statements help performance by disabling the self titled in each, remeber to re-enable at end of code
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
StartTime = Timer 'Starts timer to see how long code takes to execute. I like having this in macors that loop through files
path = "C:\Users\jjordan\Desktop\Test Dir\GA Test" & "\" 'pay attention to this line of code********
Filename = Dir(path & "*.xl??")
Set wsO = ThisWorkbook.Sheets("Sheet5")
Do While Len(Filename) > 0 'this tells the code to stop when there are no more files in the destination folder
DoEvents
Set wbk = Workbooks.Open(path & Filename, True, True)
For Each sheet In ActiveWorkbook.Worksheets
Set rRng = sheet.Range("a2:n100")
For Each rCell In rRng.Cells
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(1, 0).Value = rCell
Next rCell
Next
wbk.Close False
Filename = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
alter to this to your needs and you'll find it works perfectly :)
EDIT: Also in your code you make use of COPY & PASTE a lot. Try avoid doing this in the future. Try doing something:
ThisWorkbook.Sheets("Sheet1").Range("a1").Value = OtherWork.Sheets("Sheet1").Range("a1").Value
This is more efficient and wont bog down your code as much.
here is some offset logic
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(1, 0).Value =
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(0, 1).Value =
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(0, 2).Value =
notice the Offset(x,y) value? Essentially x is down and y is right. this is of course referencing the original position. So to get a value to go in the same row but three columns over you would use "Offset(0,3)" etc etc
Ill let you alter your code to do this. :)
I guess actually trying to piece it together was a struggle? Here this version assumes the macro is in the master workbook(and that youre running it form the master). If you want to change go ahead, but this is as far as I go. At some point, you'll have to experiment on your own.
I need help saving specific tabs from excel workbooks as 1) csv files, and 2) files named after the file from which they originate.
So far I have this which works in taking out the right tab from a single workbook and saving it as a .csv file.
Sub Sheet_SaveAs()
Dim wb As Workbook
Sheets("SheetName").Copy
Set wb = ActiveWorkbook
With wb
.SaveAs ThisWorkbook.Path & "\SheetName.csv"
'.Close False
End With
End Sub
How do I rename "SheetName" so that the file saves as, for example, Workbook1SheetName, Workbook2SheetName etc.?
I want to loop this function through a folder of many, many excel files, so unique names are necessary for the new .csv files.
I found this online which shows how to use a VBA loop, http://www.ozgrid.com/VBA/loop-through.htm. In theory it should work with my code above as long as each .csv file can have a unique name. Correct me if I am wrong.
Thanks for the help.
As you've discovered, when you copy a worksheet with no destination you end up with a new workbook populated by the copy of worksheet. The new workbook becomes the ActiveWorkbook property in the VBA environment. To save the workbook as a CSV file you need to retrieve the Worksheet .Name property of the sole worksheet in that new workbook.
Sub All_Sheet_SaveAs_CSV()
Dim w As Long, wb As Workbook
Dim fp As String, fn As String
On Error GoTo bm_Safe_Exit
'Application.ScreenUpdating = False 'stop screen flashing
Application.DisplayAlerts = False 'stop confirmation alerts
'start with a reference to ThisWorkbook
With ThisWorkbook
fp = .Path
'cycle through each of the worksheets
For w = 1 To Worksheets.Count
With Worksheets(w)
.Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
fn = .Worksheets(1).Name
.SaveAs Filename:=fp & Chr(92) & fn, FileFormat:=xlCSV
.Close savechanges:=False '<~~ already saved in line above
End With
End With
Next w
End With
bm_Safe_Exit:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Note that turning .DisplayAlerts will turn off the warnings that you would normally receive. While this is helpful with the CSV file format, it also will not warn you if you attempt to overwrite a file.
The Workbook.SaveAs method with a file format parameter of xlCSV will supply the correct file extension. There is no need to include it as part of the filename.
If a limited number of specific worksheets are intended to receive the export-to-CSV procedure, then an array of worksheet names could be cycled through rather than the worksheet index position.
Sub Specific_Sheets_SaveAs_CSV()
Dim v As Long, vWSs As Variant
Dim fp As String, fn As String
On Error GoTo bm_Safe_Exit
'Application.ScreenUpdating = False 'stop screen flashing
Application.DisplayAlerts = False 'stop confirmation alerts
vWSs = Array("Sheet1", "Sheet3", "Sheet5")
'start with a reference to ThisWorkbook
With ThisWorkbook
fp = .Path
'cycle through each of the worksheets
For v = LBound(vWSs) To UBound(vWSs)
With Worksheets(vWSs(v))
.Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
fn = .Worksheets(1).Name
.SaveAs Filename:=fp & Chr(92) & fn, FileFormat:=xlCSV
.Close savechanges:=False '<~~ already saved in line above
End With
End With
Next v
End With
bm_Safe_Exit:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "c:\Vouchers\"
fileName = Dir(directory & "*.csv??")
Do While fileName <> ""
Workbooks.Open (directory & fileName)
For Each sheet In Workbooks(fileName).Worksheets
total = Workbooks("Voucher Report 26MAR V1.0.xlsm").Worksheets.Count
Workbooks(fileName).Worksheets(sheet.Name).Copy _
after:=Workbooks("Voucher Report 26MAR V1.0.xlsm").Worksheets(total)
Next sheet
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The above code gets all the data I need but creates a new sheet for each workbook, is there anyway to place the data from the first workbook in row 10 then add the data from the next workbook in the next available row?
Give this a try. Note, you may have to adjust the value of your Dest worksheet, I've defined it the best I could based on your code.
Private Sub CommandButton1_Click()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Dim Dest as Worksheet
Dim DestRow as long
Dim Source as Workbook
'adjust this as necessary - it should create a new sheet at the end of
'"Voucher Report...", and call it "My New Sheet"
Set Dest = Workbooks("Voucher Report 26MAR V1.0.xlsm").Worksheets.add _
after:=Workbooks("Voucher Report 26MAR V1.0.xlsm").Worksheets.Count _
Name:="My New Sheet"
DestRow = 10
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "c:\Vouchers\"
fileName = Dir(directory & "*.csv??")
Do While fileName <> ""
'assign the opened workbook to a var for easier use
set source = Workbooks.Open (directory & fileName)
For Each sheet In source.Worksheets
'copy the UsedRange cells from the sheet
'.copy is kind of weird, but this works
sheet.cells(1,1).resize(sheet.usedrange.rows.count, sheet.usedrange.columns.count).copy
'paste doesn't apply to a range, but to a worksheet object
' the destination param tells it where to go
dest.paste destination:=range(cells(destrow,"A")
'increment the current row pointer but the number of rows used
destrow = destrow + sheet.usedrange.rows.count
Next sheet
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
All code untested, so you may have some minor tweaks. I'd suggest commenting out the ScreenUpdating lines until you have it all working correctly.
Note: I found the references for .copy here in the MS Docs, and for .paste here in the MS Docs.
Is there any way to extract the workbook name, but then extract only a part of it.
Any version of excel would be fine preferably 2003.
For example
"Help_TicketID123456788.xls"
"Help_TicketID563565464.xls"
...
So then I'd like to extract the ID numbers and put them into a column on a master worksheet in another workbook.
Additionally I'd like to extract some data from specific columns (Always the same columns) from each workbook, and put that into the master worksheet too.
Thank you!!
In your master spreadsheet you can write a VBA procedure to loop over all the xls files in a directory, extract the ID Number from each filename, and then open each file to extract the other data. This should get you started:
Sub RunCodeOnAllXLSFiles()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "C:\MyDocuments\TestResults"
.FileType = msoFileTypeExcelWorkbooks
'Optional filter with wildcard
.Filename = "Help_TicketID*.xls"
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Extract ticket #
'.FoundFiles(lCount) is the filename
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
'Read the data from wbResults and write to your master spreadsheet
wbResults.Close SaveChanges:=False
Next lCount
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Source: http://www.ozgrid.com/VBA/loop-through.htm