Hi all:
My apologies if this has been asked before in the forum, I could not find anything similar to what I need help on.
So I am looking for a set of VBA code to loop through every xls files in the folder and pick up it's file name, who it is prepared by, authorised by and management checked by. Into a mastercopy.
The problems so far are:
The folder path (C:\local folder\local directory\month\type\entity) - I could set the file path up to type but I would need to have the entity interchangeable according to what I've got in a list on EXCEL, so some sort of blanket cover covering every entity and its xls files inside.
The file name, I don't know the code to pick up each file name accordingly and pick up the name of the person who prepared it. (kind of like a vlookup that will return the file name, prepared by person's name, authorised by person's name and management checked by name)
Here is the code I've managed so far - (I have just copy and paste from places on the internet and cater according to my needs):
Sub REC()
Dim WBname As String 'Deem WBname as variable
Dim WB As Workbook 'Deem WB as workbook
Dim WS As Worksheet 'Deem WS as worksheet
Dim WS1 As Worksheet
Dim lngCalc As Long
Dim lngrow As Long
Dim Preparedby As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .CalculationState
.Calculation = xlCalculationManual
End With
Set WS1 = ThisWorkbook.Sheets("Sheet1")
FolderName = "Local path" 'set the folder path
WBname = Dir(FolderName & "" & "*.xls*") 'filename wildcard
Do While Len(WBname) > 0
Set WB = Workbooks.Open(FolderName & "" & WBname) 'open specified path and file
Set WS = Nothing 'if ws is nothing then move on
On Error Resume Next 'next line if error
Set WS = WB.Sheets("rec cert") 'pick up sheet rec cert, but it is not the only variation
On Error Resume Next
Set WS = WB.Sheets("a1 rec cert") 'pick up sheet a1 rec cert, but it is not the only variation
On Error GoTo 0
If Not WS Is Nothing Then
With WS
Set Preparedby = WS.Range("A:D").Find("prepared by", LookIn:=xlValues, LookAt:=xlWhole) 'find "prepared by" in range A:D
On Error Resume Next
Set Preparedby = Nothing
End With
With WS
Set Preparedby = WS.Range("A:D").Find("prepared by", LookIn:=xlValues, LookAt:=xlWhole)
If Not Preparedby Is Nothing Then 'if true, next line
Preparedby.Activate
ActiveCell.Offset(0, 1).Copy 'meant to pick up the name that is offset by column 1 and copy
End If
End With
With WS1
ThisWorkbook.Activate 'activate this work book
If Not ActiveCell Is Nothing Then
ActiveCell.Offset(1, 0).PasteSpecial 'destination
End If
End With
End If
WB.Close False
WBname = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With
End Sub
Perhaps anyone could advice me? I am only a beginner at VBA coding.
Many thanks in advance.
Shinn
My apologies if this has been asked before in the forum, I could not find anything similar to what I need help on.
So I am looking for a set of VBA code to loop through every xls files in the folder and pick up it's file name, who it is prepared by, authorised by and management checked by. Into a mastercopy.
The problems so far are:
The folder path (C:\local folder\local directory\month\type\entity) - I could set the file path up to type but I would need to have the entity interchangeable according to what I've got in a list on EXCEL, so some sort of blanket cover covering every entity and its xls files inside.
The file name, I don't know the code to pick up each file name accordingly and pick up the name of the person who prepared it. (kind of like a vlookup that will return the file name, prepared by person's name, authorised by person's name and management checked by name)
Here is the code I've managed so far - (I have just copy and paste from places on the internet and cater according to my needs):
Sub REC()
Dim WBname As String 'Deem WBname as variable
Dim WB As Workbook 'Deem WB as workbook
Dim WS As Worksheet 'Deem WS as worksheet
Dim WS1 As Worksheet
Dim lngCalc As Long
Dim lngrow As Long
Dim Preparedby As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .CalculationState
.Calculation = xlCalculationManual
End With
Set WS1 = ThisWorkbook.Sheets("Sheet1")
FolderName = "Local path" 'set the folder path
WBname = Dir(FolderName & "" & "*.xls*") 'filename wildcard
Do While Len(WBname) > 0
Set WB = Workbooks.Open(FolderName & "" & WBname) 'open specified path and file
Set WS = Nothing 'if ws is nothing then move on
On Error Resume Next 'next line if error
Set WS = WB.Sheets("rec cert") 'pick up sheet rec cert, but it is not the only variation
On Error Resume Next
Set WS = WB.Sheets("a1 rec cert") 'pick up sheet a1 rec cert, but it is not the only variation
On Error GoTo 0
If Not WS Is Nothing Then
With WS
Set Preparedby = WS.Range("A:D").Find("prepared by", LookIn:=xlValues, LookAt:=xlWhole) 'find "prepared by" in range A:D
On Error Resume Next
Set Preparedby = Nothing
End With
With WS
Set Preparedby = WS.Range("A:D").Find("prepared by", LookIn:=xlValues, LookAt:=xlWhole)
If Not Preparedby Is Nothing Then 'if true, next line
Preparedby.Activate
ActiveCell.Offset(0, 1).Copy 'meant to pick up the name that is offset by column 1 and copy
End If
End With
With WS1
ThisWorkbook.Activate 'activate this work book
If Not ActiveCell Is Nothing Then
ActiveCell.Offset(1, 0).PasteSpecial 'destination
End If
End With
End If
WB.Close False
WBname = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With
End Sub
Perhaps anyone could advice me? I am only a beginner at VBA coding.
Many thanks in advance.
Shinn
