AnilPullagura
Board Regular
- Joined
- Nov 19, 2010
- Messages
- 98
Hello All,
I have written a macro to collate data from numerous workbooks to a single one. This works well for the 1st workbook and from the second workbook, i noticed a weird thing.
The last row of data retrieved from 1st workbook is being stored in the variable and when the next workbook data is stored the Data Collation workbook, it populates the rowdata from 1st workbook for each and every row.
Here is the raw macro: Please suggest if I can improvise on this and fix the bug
I have written a macro to collate data from numerous workbooks to a single one. This works well for the 1st workbook and from the second workbook, i noticed a weird thing.
The last row of data retrieved from 1st workbook is being stored in the variable and when the next workbook data is stored the Data Collation workbook, it populates the rowdata from 1st workbook for each and every row.
Here is the raw macro: Please suggest if I can improvise on this and fix the bug
Code:
Public objFSO As Object
Public objFolder As Object
Public FileName As Object
Public i As Long
Public k()
Sub ListFiles()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim StartFolder
Set objFSO = CreateObject("Scripting.FileSystemObject")
StartFolder = "C:\Documents and Settings\apullagura\Desktop\Dashboard July 2011"
Set objFolder = objFSO.GetFolder(StartFolder)
SubFoldersFiles objFSO.GetFolder(StartFolder)
Dim wb As Workbook, wbCur As Workbook
Dim pName As String
'Dim shname As String
Dim arrOutput()
Dim opCols(1 To 6) As Long
Dim ColHeads, j As Long, n As Long, c As Long
'Dim wbOpen As Boolean: wbOpen = False
Set wbCur = Workbooks("Data Collation.xls")
ReDim arrOutput(1 To 1000, 1 To 10)
ColHeads = Array("EmpName", "ProcessName", "ProdTarget", "Production", "Date", "ProductiveHours")
With wbCur.Worksheets("OpsProdData") '<<==adjust to suit
Range("A2:F65536").Clear
On Error Resume Next
For j = 0 To UBound(ColHeads)
opCols(j + 1) = Cells.Find(What:=CStr(ColHeads(j)), LookAt:=xlPart).Column
Next
End With
For i = 1 To UBound(k)
Dim wbOpen As Boolean: wbOpen = False
For Each wb In Application.Workbooks
If wb.Name = k(i) Then
wbOpen = True
wb.Activate
End If
Next
If wbOpen = False Then
Set wb = Workbooks.Open(k(i), 0)
End If
n = n + 1
'DATA TRANSFERRED TO VARIABLES
With wb.Worksheets("Daily Production")
inpt_col = Cells.Find(What:="S.No.", LookAt:=xlPart, MatchCase:=False).Offset(0, 1).Column
inpt_lst_rw = Cells.Find(What:="S.No.", LookAt:=xlWhole, MatchCase:=True).End(xlDown).Offset(-1, 0).Row
s = Cells.Find(What:="S.No.", LookAt:=xlWhole, MatchCase:=True).Offset(1, 0).Value
If s = 1 Then
inpt_fst_rw = Cells.Find(What:="S.No.", LookAt:=xlWhole, MatchCase:=True).Offset(1, 0).Row
Else
inpt_fst_rw = Cells.Find(What:="S.No.", LookAt:=xlWhole, MatchCase:=True).Offset(2, 0).Row
End If
'MsgBox inpt_lst_rw
'MsgBox inpt_fst_rw
For m = inpt_fst_rw To inpt_lst_rw
arrOutput(n, 1) = .Cells(m, inpt_col).Value
b = Cells.Find(What:="S.No.", LookAt:=xlWhole, MatchCase:=True).Offset(0, 2).Value
If b <> "" Then
inpt_q_lst_col = Cells.Find(What:="Total", LookAt:=xlWhole, MatchCase:=True).Offset(0, -1).Column
inpt_q_fst_col = Cells.Find(What:="S.No.", LookAt:=xlWhole, MatchCase:=True).Offset(0, 2).Column
Else
inpt_q_lst_col = Cells.Find(What:="Total", LookAt:=xlWhole, MatchCase:=False).Offset(0, -1).Column
inpt_q_fst_col = Cells.Find(What:="S.No.", LookAt:=xlWhole, MatchCase:=False).Offset(0, 3).Column
End If
For c = inpt_q_fst_col To inpt_q_lst_col
arrOutput(n, 2) = .Cells(3, c).Value
arrOutput(n, 3) = .Cells(3, c).Offset(1, 0).Value
arrOutput(n, 4) = .Cells(m, c).Value
arrOutput(n, 5) = Left((Now() - 1), 8)
g = Cells.Find(What:="Productive Hours", LookAt:=xlWhole, MatchCase:=False).Column
arrOutput(n, 6) = .Cells(m, g).Value
'If arrOutput(n, 2) <> "" Then GoTo Line1 Else GoTo Line2:
'Line1:
If n Then
wbCur.Activate
With wbCur.Worksheets("OpsProdData")
e = Cells(2, 1).Value
If e <> "" Then
f = Range("A65536").End(xlUp).Offset(1, 0).Row
.Range("a" & f).Resize(n, 6).Value = arrOutput
Else
.Range("A2").Resize(n, 6).Value = arrOutput
End If
End With
End If
Next c
'Line2:
Next m
End With
wb.Close
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'Msg = MsgBox("Report is Generated", vbOKOnly, "SUMMARY REPORT")
Erase k
i = Empty
End Sub
Sub SubFoldersFiles(Folder)
Dim objfilename As String
objfilename = "Dash"
For Each SubFolder In Folder.SubFolders
Set objFolder = objFSO.GetFolder(SubFolder.Path)
For Each FileName In objFolder.Files
If FileName.Name Like "*" & objfilename & "*" Then
i = i + 1
ReDim Preserve k(1 To i)
k(i) = objFolder & "\" & FileName.Name
End If
Next
SubFoldersFiles SubFolder
Next
End Sub
