Data Collation Macro BUG

[AnilPullagura]

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

  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

 

[Norie]

Anil

Nothing wrong with using a lot of variables, as long as you know what they do in the code.

Try using more descriptive names for them.

 

[RoryA]

Change this:

ReDim arrOutput(1 To 1000, 1 To 10)

to this:

ReDim arrOutput(1 To 1, 1 To 10)

and change the n = n + 1 line to just n = 1

 

[AnilPullagura]

Thanks a ton Rory, it worked and eased a lot of pressure on me..... But if you can teach me as how you were able to deduce this stuff, It will be a learning for me....

Please do that at your leisure time.

Thanks once again. Happy Weekend.

--Anil