Hello,
So I'm a new intern at this company which has asked me to create a file to start tracking hours spent on different jobs (it is an engineering firm). Basically, there are hundreds of excel files which have whole number counts of hours with jobs for rows and dates for columns. I found a macro which pulls all the files from one folder but now I need to start formatting it.
I don't have much experience with VBA, notice the college student internship, but know that learning VBA can really give me a hands up getting a job. Using the code below I get one huge worksheet with everything but have a "stacking" problem. I need it to look more like this. Sorry, I don't know how to post pictures.
Date Date Date Date Date Date Date
Job 1 2 5
Job 2 3 3
Job 3 4 2
It currently looks like...
Date Date Date Date
Job 1 2 5
Job 4
Job 3 4
Date Date Date
Job 2 3 3
Job 3 2
The current code I used was:
Sub MergeAllWorkbooks() Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long ' Change this to the path\folder location of your files. MyPath = "C:\Users\Ron\test" ' Add a slash at the end of the path if needed. If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If ' If there are no Excel files in the folder, exit. FilesInPath = Dir(MyPath & "*.xl*") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If ' Fill the myFiles array with the list of Excel files ' in the search folder. FNum = 0 Do While FilesInPath <> "" FNum = FNum + 1 ReDim Preserve MyFiles(1 To FNum) MyFiles(FNum) = FilesInPath FilesInPath = Dir() Loop ' Set various application properties. With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With ' Add a new workbook with one sheet. Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1 ' Loop through all files in the myFiles array. If FNum > 0 Then For FNum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next ' Change this range to fit your own needs. With mybook.Worksheets(1) Set sourceRange = .Range("A1:C1") End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else ' If source range uses all columns then ' skip this file. If sourceRange.Columns.Count >= BaseWks.Columns.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0 If Not sourceRange Is Nothing Then SourceRcount = sourceRange.Rows.Count If rnum + SourceRcount >= BaseWks.Rows.Count Then MsgBox "There are not enough rows in the target worksheet." BaseWks.Columns.AutoFit mybook.Close savechanges:=False GoTo ExitTheSub Else ' Copy the file name in column A. With sourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = MyFiles(FNum) End With ' Set the destination range. Set destrange = BaseWks.Range("B" & rnum) ' Copy the values from the source range ' to the destination range. With sourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value rnum = rnum + SourceRcount End If End If mybook.Close savechanges:=False End If Next FNum BaseWks.Columns.AutoFit End If ExitTheSub: ' Restore the application properties. With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub </pre>Any help is greatly appreciated!
So I'm a new intern at this company which has asked me to create a file to start tracking hours spent on different jobs (it is an engineering firm). Basically, there are hundreds of excel files which have whole number counts of hours with jobs for rows and dates for columns. I found a macro which pulls all the files from one folder but now I need to start formatting it.
I don't have much experience with VBA, notice the college student internship, but know that learning VBA can really give me a hands up getting a job. Using the code below I get one huge worksheet with everything but have a "stacking" problem. I need it to look more like this. Sorry, I don't know how to post pictures.
Date Date Date Date Date Date Date
Job 1 2 5
Job 2 3 3
Job 3 4 2
It currently looks like...
Date Date Date Date
Job 1 2 5
Job 4
Job 3 4
Date Date Date
Job 2 3 3
Job 3 2
The current code I used was:
Sub MergeAllWorkbooks() Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long ' Change this to the path\folder location of your files. MyPath = "C:\Users\Ron\test" ' Add a slash at the end of the path if needed. If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If ' If there are no Excel files in the folder, exit. FilesInPath = Dir(MyPath & "*.xl*") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If ' Fill the myFiles array with the list of Excel files ' in the search folder. FNum = 0 Do While FilesInPath <> "" FNum = FNum + 1 ReDim Preserve MyFiles(1 To FNum) MyFiles(FNum) = FilesInPath FilesInPath = Dir() Loop ' Set various application properties. With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With ' Add a new workbook with one sheet. Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1 ' Loop through all files in the myFiles array. If FNum > 0 Then For FNum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next ' Change this range to fit your own needs. With mybook.Worksheets(1) Set sourceRange = .Range("A1:C1") End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else ' If source range uses all columns then ' skip this file. If sourceRange.Columns.Count >= BaseWks.Columns.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0 If Not sourceRange Is Nothing Then SourceRcount = sourceRange.Rows.Count If rnum + SourceRcount >= BaseWks.Rows.Count Then MsgBox "There are not enough rows in the target worksheet." BaseWks.Columns.AutoFit mybook.Close savechanges:=False GoTo ExitTheSub Else ' Copy the file name in column A. With sourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = MyFiles(FNum) End With ' Set the destination range. Set destrange = BaseWks.Range("B" & rnum) ' Copy the values from the source range ' to the destination range. With sourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value rnum = rnum + SourceRcount End If End If mybook.Close savechanges:=False End If Next FNum BaseWks.Columns.AutoFit End If ExitTheSub: ' Restore the application properties. With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub </pre>Any help is greatly appreciated!
