Hi
I have a workbook which pulls data from a number of closed workbooks in a folder and collates all of that information and makes it so I can quickly and easily summarise data in a single sheet from hundreds of workbooks. I have subscribed to the office 365 suite and the workbook doesn't work with excel 2016. It comes up with a message saying that it won't work because the workbook is protected but I even turned off all protection settings on all of the sheets and it tries to work but it doesn't seem to place the data correctly and just stops without an error. Does anyone have any idea of what it could be that could be occurring?
This file is the workbook which contains the information I wish to extract. I quite often have hundreds of these in a folder containing all of the data I need to produce the figures I want https://www.dropbox.com/s/g3dlvusrh36bxze/01 QUOTE LIST TEMPLATE ALL UNITS V3.5.xlsx?dl=0. This file contains no VBA coding
This file is the workbook which I use to extract the data from all of my closed workbooks https://www.dropbox.com/s/dalm3csd0uw4x3y/02 PROFIT WORKINGS V1.7.xlsm?dl=0 this file contains all of the VBA coding in which I use to automate the process of opening and closing the closed workbooks within a folder and copying all of the data required.
The VBA code in question
I hope I have explained myself well enough for someone to understand what I am trying to do and what my problem is. i probably have stuffed up with the VBA coding as I am not terribly proficient with VBA
I have a workbook which pulls data from a number of closed workbooks in a folder and collates all of that information and makes it so I can quickly and easily summarise data in a single sheet from hundreds of workbooks. I have subscribed to the office 365 suite and the workbook doesn't work with excel 2016. It comes up with a message saying that it won't work because the workbook is protected but I even turned off all protection settings on all of the sheets and it tries to work but it doesn't seem to place the data correctly and just stops without an error. Does anyone have any idea of what it could be that could be occurring?
This file is the workbook which contains the information I wish to extract. I quite often have hundreds of these in a folder containing all of the data I need to produce the figures I want https://www.dropbox.com/s/g3dlvusrh36bxze/01 QUOTE LIST TEMPLATE ALL UNITS V3.5.xlsx?dl=0. This file contains no VBA coding
This file is the workbook which I use to extract the data from all of my closed workbooks https://www.dropbox.com/s/dalm3csd0uw4x3y/02 PROFIT WORKINGS V1.7.xlsm?dl=0 this file contains all of the VBA coding in which I use to automate the process of opening and closing the closed workbooks within a folder and copying all of the data required.
The VBA code in question
Code:
Sub RunAllMacros()CommandButton1_Click
test
End Sub
Sub CommandButton1_Click()
Dim x, fldr As FileDialog, SelFold As String, i As Long
Dim ws As Worksheet, ws1 As Worksheet
Dim Wb As Workbook, Filename As String
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("cmd /c Dir """ & SelFold & "\*.xls"" /s/b").stdout.readall, vbCrLf)
Set ws1 = ThisWorkbook.Sheets("Labour & Material")
Set ws2 = ThisWorkbook.Sheets("Total Hours For All Units")
'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 lngrow = 0 Then
lngrow = 5
Else
lngrow = lngrow + 1
End If
ws1.Cells(lngrow, "A").Value = ws.Range("A1").Value
ws1.Cells(lngrow, "B").Value = ws.Range("I2").Value
ws1.Cells(lngrow, "C").Value = ws.Range("C2").Value
ws1.Cells(lngrow, "E").Value = ws.Range("C3").Value
ws1.Cells(lngrow, "G").Value = ws.Range("C4").Value
ws2.Cells(lngrow, "B").Value = ws.Range("B8").Value
ws2.Cells(lngrow, "C").Value = ws.Range("B9").Value
ws2.Cells(lngrow, "D").Value = ws.Range("B10").Value
ws2.Cells(lngrow, "E").Value = ws.Range("B11").Value
ws2.Cells(lngrow, "F").Value = ws.Range("B12").Value
ws2.Cells(lngrow, "G").Value = ws.Range("B13").Value
End If
.Close
End With
Next i
Cleanup:
Set fldr = Nothing
End Sub
Sub test()
SheetNum = Array(1, 2, 5, 6)
For Each Sh In Sheets(SheetNum)
Sh.Select
Set SoRng = Sh.Range("A5", Sh.Range("A5").End(xlToRight).Address)
AdvFil SoRng
Next
Sheets(4).Select
Set SoRng = Sheets(4).Range("A5:A5")
AdvFil SoRng
Sheets(3).Select
ColNo = Array("D", "F", "H")
For Each Col In ColNo
Set SoRng = Sheets(3).Range(Col & "5:" & Col & "5")
AdvFil SoRng
Next
End Sub
Sub AdvFil(ByVal x As Range)
LrNum = Sheets(3).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
I hope I have explained myself well enough for someone to understand what I am trying to do and what my problem is. i probably have stuffed up with the VBA coding as I am not terribly proficient with VBA
Last edited: