-
Hi Mr. Ken,
Sorry to bother you so much, I am almost at at my reach, but something is missing. It dubug on PathO, saying variant not defined.
See below modified code:
[VBA]Option Explicit
Public glb_origCalculationMode As Integer
Sub SpeedOn(Optional StatusBarMsg As String = "Running macro...")
glb_origCalculationMode = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Cursor = xlWait
.StatusBar = StatusBarMsg
.EnableCancelKey = xlErrorHandler
End With
End Sub
Sub SpeedOff()
With Application
.Calculation = glb_origCalculationMode
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.CalculateBeforeSave = True
.Cursor = xlDefault
.StatusBar = False
.EnableCancelKey = xlInterrupt
End With
End Sub
Sub DoUpdates()
Dim pFolder As String, fileList As Variant, f As Variant
Dim ws As Worksheet
Dim slaveWB As Workbook
On Error GoTo TheEnd
SpeedOn
'Set the parent folder of slave workbooks to process.
pFolder = "C:\Test" & "\" '<-------- Change as needed.
' Open each workbook except thisworkbook and get the data.
fileList = GetFileList(pFolder & "*.xl*")
For Each f In fileList
If ThisWorkbook.Name = f Then GoTo Nextf
'Do your thing from here to Nextf.
Set slaveWB = Workbooks.Open(pFolder & f)
'Add the data from slave to master.
For Each ws In slaveWB.Worksheets
ws.Activate
Run_Updates
Next ws
slaveWB.Close True
Nextf:
Next f
TheEnd:
SpeedOff
End Sub
Sub Run_Updates()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Select
Range("A1").End(xlDown).Offset(1).Select
ActiveWindow.SmallScroll Down:=1
Updates
Next ws
End Sub
Sub Updates()
Dim n As Long, k As Long
Range(ActiveCell, ActiveCell.Offset(Val(1) - 1, 0)).EntireRow.Insert
k = ActiveCell.Offset(-1, 0).Row
n = Cells(k, 84).End(xlToLeft).Column
Range(Cells(k, 84), Cells(k + Val(1), n)).FillDown
With ActiveCell
.Value = Format(Date, "dd-mmm-yy")
.Offset(0, 1).Value = "MH"
End With
Dim SheetName As String
Dim ActiveDate As String
PathO = "C:\Bhav Copy"
SheetName = ActiveSheet.Name
ActiveDate = Cells(ActiveCell.Row, 1)
DD = Mid(ActiveDate, 1, 2)
MM = Mid(ActiveDate, 4, 3)
YY = Mid(ActiveDate, 8, 2)
MMO = Format(CDate(Range("A" & ActiveCell.Row)), "mm")
FileNameO = PathO + "EQ" + DD + MMO + YY + ".CSV"
If Dir(FileNameO) = "" Then
MsgBox "File Doesn't Exist (" + FileNameO + ")"
Exit Sub
End If
SheetName = UCase(SheetName)
Open FileNameO For Input As #1
While Not EOF(1)
Input #1, A1$, A2$, A3$, A4$, A5$, A6$, A7$, A8$, A9$, A10$, A11$, A12$, A13$, A14$
If A2 = SheetName Then
Cells(ActiveCell.Row, 2) = A5$
Cells(ActiveCell.Row, 3) = A6$
Cells(ActiveCell.Row, 4) = A7$
Cells(ActiveCell.Row, 5) = A8$
Cells(ActiveCell.Row, 6) = A12$
Close #1
Exit Sub
End If
Wend
Close #1
EndNow:
SpeedOff
End Sub
Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
[/VBA]
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules