Hi
I have had this persistent problem with just my personal PC at home. On all other PC's I have in my house and work PC's the code executes fine but on mine it doesn't.
What it is supposed to do is to search through a folder for excel files open each one copy the data from a sheet within those excel files and paste it into the workbook and continue down until there are no more excel files within the folder. What I have found is that instead of pasting down to the next row below the initial row it goes to paste up to the next row above the initial row but it only does this from within dropbox on my PC. If the folder containing the excel files is on the desktop then it will execute fine but if that same folder is within dropbox then it reverses the direction in which it is supposed to paste the data.
On all the other PC's I have tested from within Dropbox everything works fine. Is there something I have done wrong - I am not very good with VBA code so I may have stuffed it up and it could be broken but still works but I have no idea. - Also not a major issue and one that doesn't really bother me but if I only have one file it still executes except it comes up with an error (Run-time error '1004': AutoFill method of Range class failed) and when I hit debug it highlights x.AutoFill Destination:=Range (DesRng). This doesn't bother me so much as it still pastes the required data and I rarely ever have one single file.
If anyone could help it would be greatly appreciated thanks. Below is the entire code I run -
If more information is needed or I need to upload example files let me know and I'll do what I can
I have had this persistent problem with just my personal PC at home. On all other PC's I have in my house and work PC's the code executes fine but on mine it doesn't.
What it is supposed to do is to search through a folder for excel files open each one copy the data from a sheet within those excel files and paste it into the workbook and continue down until there are no more excel files within the folder. What I have found is that instead of pasting down to the next row below the initial row it goes to paste up to the next row above the initial row but it only does this from within dropbox on my PC. If the folder containing the excel files is on the desktop then it will execute fine but if that same folder is within dropbox then it reverses the direction in which it is supposed to paste the data.
On all the other PC's I have tested from within Dropbox everything works fine. Is there something I have done wrong - I am not very good with VBA code so I may have stuffed it up and it could be broken but still works but I have no idea. - Also not a major issue and one that doesn't really bother me but if I only have one file it still executes except it comes up with an error (Run-time error '1004': AutoFill method of Range class failed) and when I hit debug it highlights x.AutoFill Destination:=Range (DesRng). This doesn't bother me so much as it still pastes the required data and I rarely ever have one single file.
If anyone could help it would be greatly appreciated thanks. Below is the entire code I run -
VBA Code:
Option Explicit
Sub RunAllMacros()
CommandButton1_Click
test
sortMyData
delrowsifzero
consolidatedata
End Sub
Sub CommandButton1_Click()
Dim x, fldr As FileDialog, SelFold As String, i As Long
Dim ws As Worksheet, ws1, ws2, ws3 As Worksheet
Dim Wb As Workbook, Filename As String
Dim screenUpdateState As String
Dim statusBarState As String
Dim eventsState As String
Dim lngrow As Long
Dim lngrow1 As Long
screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
eventsState = Application.EnableEvents
'turn off some Excel functionality for faster performance
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
'User Selects desired Folder
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
If .Show <> -1 Then GoTo Cleanup
SelFold = .SelectedItems(1)
End With
'All .xls* files in Selected FolderPath including Sub folders are put into an array
x = Split(CreateObject("wscript.shell").exec("c:\temp\cmd.exe /c Dir """ & SelFold & "\*.xls"" /s/b").stdout.readall, vbCrLf)
Set ws1 = ThisWorkbook.Sheets("Labour & Material")
Set ws2 = ThisWorkbook.Sheets("Total Hours For All Units")
Set ws3 = ThisWorkbook.Sheets("Materials Summary")
'Loop through that array
For i = LBound(x) To UBound(x) - 1
'Open (in background) the Workbook
With GetObject(x(i))
ThisWorkbook.Sheets(1).UsedRange
Filename = Split(x(i), "\")(UBound(Split(x(i), "\")))
Set Wb = Workbooks(Filename)
Set ws = Nothing
'On Error Resume Next
'change sheet name here
Set ws = Wb.Sheets("Total Quantities")
On Error GoTo 0
If Not ws Is Nothing Then
If lngrow1 = 0 Then
lngrow1 = 5
Else
lngrow1 = lngrow1 + 1
lngrow = lngrow + 275
End If
ws1.Cells(lngrow1, "A").Value = ws.Range("A1").Value
ws1.Cells(lngrow1, "B").Value = ws.Range("I2").Value
ws1.Cells(lngrow1, "C").Value = ws.Range("C2").Value
ws1.Cells(lngrow1, "E").Value = ws.Range("C3").Value
ws1.Cells(lngrow1, "G").Value = ws.Range("C4").Value
ws2.Cells(lngrow1, "B").Value = ws.Range("B8").Value
ws2.Cells(lngrow1, "C").Value = ws.Range("B9").Value
ws2.Cells(lngrow1, "D").Value = ws.Range("B10").Value
ws2.Cells(lngrow1, "E").Value = ws.Range("B11").Value
ws2.Cells(lngrow1, "F").Value = ws.Range("B12").Value
ws2.Cells(lngrow1, "G").Value = ws.Range("B13").Value
ws2.Cells(lngrow1, "H").Value = ws.Range("B14").Value
ws3.Range("A2:A228").Offset(lngrow, 0).Value = ws.Range("A16:A242").Value
ws3.Range("B2:B228").Offset(lngrow, 0).Value = ws.Range("C16:C242").Value
ws3.Range("E2:E228").Offset(lngrow, 0).Value = ws.Range("H16:H242").Value
ws3.Range("D2:D228").Offset(lngrow, 0).Value = ws.Range("E16:E242").Value
ws3.Range("F2:F228").Offset(lngrow, 0).Value = ws.Range("F16:F242").Value
ws3.Range("A229:A275").Offset(lngrow, 0).Value = ws.Range("I16:I62").Value
ws3.Range("b229:b275").Offset(lngrow, 0).Value = ws.Range("J16:J62").Value
ws3.Range("d229:d275").Offset(lngrow, 0).Value = ws.Range("K16:K62").Value
ws3.Range("e229:e275").Offset(lngrow, 0).Value = ws.Range("l16:l62").Value
End If
.Close
End With
Next i
Cleanup:
Set fldr = Nothing
End Sub
Sub test()
Dim SheetNum As Variant
Dim Sh As Variant
Dim SoRng As Variant
Dim ColNo As Variant
Dim Col As Variant
SheetNum = Array(2, 3, 6, 8)
For Each Sh In Sheets(SheetNum)
Sh.Select
Set SoRng = Sh.Range("A5", Sh.Range("A5").End(xlToRight).Address)
AdvFil SoRng
Next
Sheets(5).Select
Set SoRng = Sheets(5).Range("A5:A5")
AdvFil SoRng
Sheets(5).Select
Set SoRng = Sheets(5).Range("i5:q5")
AdvFil SoRng
Sheets(4).Select
ColNo = Array("D", "F", "H")
For Each Col In ColNo
Set SoRng = Sheets(4).Range(Col & "5:" & Col & "5")
AdvFil SoRng
Next
End Sub
Sub AdvFil(ByVal x As Range)
Dim LrNum As String
Dim DesRng As Variant
LrNum = Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row
If InStr(1, x.Address, ":") > 0 Then
DesRng = Left(x.Address, Len(x.Address) - 1) & LrNum
Else
DesRng = x.Address & ":" & Left(x.Address, Len(x.Address) - 1) & LrNum
End If
x.AutoFill Destination:=Range(DesRng)
End Sub
Sub sortMyData()
Dim LastRow As Long
Dim myRng As Range
With ActiveWorkbook.Worksheets("Materials Summary")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set myRng = .Range("a1:f" & LastRow)
myRng.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With
End Sub
Sub delrowsifzero()
Application.ScreenUpdating = False
Dim LastRow As Long
Worksheets("Materials Summary").Activate
On Error Resume Next
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim x As Long
ActiveWorkbook.Worksheets("Materials Summary").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Materials Summary").Sort.SortFields.Add Key:=Range("A2:f" & LastRow) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Materials Summary").Sort
.SetRange Range("A:f" & LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For x = LastRow To 2 Step -1
If Cells(x, 2) = "" Or Cells(x, 2) = 0 Then
Rows(x).EntireRow.Delete
End If
Next x
Application.ScreenUpdating = True
End Sub
Sub consolidatedata()
Worksheets("Materials Summary").Range("h2").Consolidate _
Sources:=Array("Materials Summary!data"), _
Function:=xlSum, LeftColumn:=True
Sheets("Overall Summary").Select
End Sub
If more information is needed or I need to upload example files let me know and I'll do what I can