Adapt VBA code to move worksheets from various locations into one workbook

daisyplastow

New Member
Joined
May 19, 2017
Messages
1
Hi,

I'm new to the forums and need some helping in adapting some code please. The code below currently works great, it cycles through folders in a set location to open and copy worksheet "ExportCSV" from many workbooks, in these folders.

What I need it to do instead is rather than creating a new csv file for each workbook, is to create a new sheet in the master workbook ie the workbook the code is running in. I want to keep the process it currently does, in documenting the folder/name/location etc in the sheet "overview".

Ideally the worksheets should be named the same as the source workbooks...

Can anyone please help?

Current Code:
Sub GetSheets()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Cells(2, 2) = Now
Dim objFSO As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim objFolder1 As Object
Dim cfName As String
Dim i As Integer
Dim MasterCSV As Workbook
Dim SourceCSV As Workbook
Dim wbName As String
Dim fName As String
Dim ffName As String
Dim cName As String
Dim rE As Integer
Dim MinDate As Date
Dim MaxDate As Date
Dim Vol As Single
Set MasterCSV = Application.ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("\\pggbssc1fil011.bsg.local\Man_DocHandling\Forecasting\Daisy Development 2017\Test Area")
i = 15
For Each objSubFolder In objFolder.subfolders
Dim aFile As String
aFile = objFolder.Path & "" & objSubFolder.Name & "\thumbs.db"
On Error Resume Next
If Len(Dir$(aFile)) > 0 Then
Kill aFile
End If
cfName = objFolder.Path & "" & objSubFolder.Name 'current folder name
Set objFolder1 = objFSO.GetFolder(cfName)
Sheets("Overview").Cells(i + 1, 1) = objSubFolder.Name
Sheets("Overview").Cells(i + 1, 8) = Now
For Each objFile In objFolder1.Files
ffName = objFile.Path
fName = objFile.Name
cName = Left(fName, Len(fName) - 4)
Application.StatusBar = "Creating " & cName & " CSV"
Sheets("Overview").Cells(i + 1, 2) = objFile.Name
Sheets("Overview").Cells(i + 1, 3) = objFile.Path

Set SourceCSV = Application.Workbooks.Open(ffName)
Sheets("ExportCSV").Visible = True
Sheets("ExportCSV").Select
rE = Application.CountA(Range(Cells(1, 1), Cells(65536, 1)))
MinDate = Application.Min(Range(Cells(1, 2), Cells(rE, 2)))
MaxDate = Application.Max(Range(Cells(1, 2), Cells(rE, 2)))
Vol = Application.Sum(Range(Cells(1, 5), Cells(rE, 5)))
ActiveSheet.Unprotect "secret"
If rE = 0 Then
Else

ActiveSheet.Unprotect "secret"
Range(Cells(1, 2), Cells(rE, 2)).NumberFormat = "d/mmm/yy"
Sheets("ExportCSV").Copy
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim tCSV As String
If Left(cName, 4) = "Game" Then
TempFilePath = "\\pggbssc1fil011.bsg.local\Man_DocHandling\Forecasting\Daisy Development 2017\Test Area"
Else
TempFilePath = "\\pggbssc1fil011.bsg.local\Man_DocHandling\Forecasting\Daisy Development 2017\Test Area"
End If
TempFileName = cName
FileExtStr = ".csv"
tCSV = TempFileName & FileExtStr

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=xlCSVMSDOS, CreateBackup:=False
ActiveSheet.Unprotect "secret"
BulkBagUpdate tCSV, rE, TempFileName
ActiveWorkbook.Close TempFilePath & TempFileName & FileExtStr
Application.DisplayAlerts = True

End If
CloseWithoutSave fName
Sheets("Overview").Select
Cells(i + 1, 4) = MinDate
Cells(i + 1, 5) = MaxDate
Cells(i + 1, 6) = Vol
Cells(i + 1, 7) = rE
Cells(i + 1, 9) = Now
Cells(i + 1, 10) = Cells(i + 1, 9) - Cells(i + 1, 8)
i = i + 1
Cells(i + 1, 8) = Now
Next objFile
Next objSubFolder
Cells(2, 3) = Now
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
 

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

Forum statistics

Threads
1,213,543
Messages
6,114,236
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top