Data Collation Macro BUG

A

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

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
 
Sort by date Sort by votes
Thanks Ruddles, It is clear now atleast. Am a dumbo I know that....:)

Rory,

I did comment on the "On Error Resume Next" line but i received a run time error 91: "Object Variable or With block Variable not set"

and I did make changes to

If wb.FullName = k(i) Then
Click to expand...

Eager to find an answer for this. Its been 36hrs that I am stuck here...

Anil
 
Upvote 0

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
On which line do you get the error?
 
Upvote 0
Then one of your column headers is not being found. You should always test the result of a Find before trying to use the found range.
 
Upvote 0
I've made a few assumptions and altered a few things, but try this:
Code: 
Public objFSO       As Object
Public objFolder    As Object
Public FileName     As Object
Public i            As Long
Public k()

Sub ListFiles()
   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, m As Long, f As Long
   Dim StartFolder
   Dim wbOpen As Boolean
   Dim wksDaily As Worksheet
   Dim rngSerialNo As Range
   Dim rngTotal As Range
   Dim rngProdHours As Range
   Dim inpt_col As Long
   Dim inpt_lst_rw As Long, inpt_fst_rw As Long
   Dim inpt_q_lst_col As Long, inpt_q_fst_col As Long
   Dim s, b, e   ' don't know what types these should be
   
   ColHeads = Array("EmpName", "ProcessName", "ProdTarget", "Production", "Date", "ProductiveHours")
   StartFolder = "C:\Documents and Settings\apullagura\Desktop\Dashboard July 2011"

   Application.ScreenUpdating = False
   Application.DisplayAlerts = False

   Set objFSO = CreateObject("Scripting.FileSystemObject")
   Set objFolder = objFSO.GetFolder(StartFolder)

   ' set up file list
   SubFoldersFiles objFolder


   Set wbCur = Workbooks("Data Collation.xls")

   ReDim arrOutput(1 To 1000, 1 To 10)


   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
      On Error GoTo 0
   End With

   For i = 1 To UBound(k)
      ' check if workbook already open
      wbOpen = False
      For Each wb In Application.Workbooks
         If wb.FullName = k(i) Then
            wbOpen = True
            Exit For
         End If
      Next wb
      ' if not, then open it
      If wbOpen = False Then
         Set wb = Workbooks.Open(k(i), 0)
      End If

      n = n + 1
      'DATA TRANSFERRED TO VARIABLES
      Set wksDaily = wb.Worksheets("Daily Production")
      With wksDaily

         Set rngSerialNo = .Cells.Find(What:="S.No.", LookAt:=xlPart, MatchCase:=False)
         Set rngTotal = .Cells.Find(What:="Total", LookAt:=xlWhole, MatchCase:=True).Offset(0, -1)
         ' check "S.No." was found
         If Not rngSerialNo Is Nothing Then
            With rngSerialNo
               inpt_col = .Column + 1
               inpt_lst_rw = .End(xlDown).Offset(-1, 0).Row
               s = .Offset(1, 0).Value
               If s = 1 Then
                  inpt_fst_rw = .Offset(1, 0).Row
               Else
                  inpt_fst_rw = .Offset(2, 0).Row
               End If
            End With

            '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 = rngSerialNo.Offset(0, 2).Value

               If Not rngTotal Is Nothing Then
                  inpt_q_lst_col = rngTotal.Column
               Else
                  inpt_q_lst_col = 0
               End If

               If b <> "" Then
                  inpt_q_fst_col = rngSerialNo.Offset(0, 2).Column
               Else
                  inpt_q_fst_col = rngSerialNo.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)
                  Set rngProdHours = .Cells.Find(What:="Productive Hours", LookAt:=xlWhole, MatchCase:=False)
                  If Not rngProdHours Is Nothing Then arrOutput(n, 6) = .Cells(m, rngProdHours.Column).Value

                  If n Then
                     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 If

      End With

      wb.Close


   Next i


   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
   Dim SubFolder
   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 SubFolder
End Sub
 
Upvote 0
Hey Rory, thanks for the motivating stuff.. I did try out your code and the same issue still persists. My gut feeling is that there should be an issue in the below portion of the code.

If n Then
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
Click to expand...

The variable arrOutput is retaining the last value to the next workbook..... This is my assumption. Please help me out with this.

Thanks,
Anil
 
Upvote 0
Ah - you aren't increasing n within the loops for m or c so you appear to be overwriting the same data in the arrays repeatedly. I think you need to:
1. Reset n to 1 after the For i = ... line
2. Erase Arroutput before the Next i line just to ensure you don't get the same data repeated.
3. Increment n within the inner loops; you are looping through rows and columns and populating the same row and columns of the array every time. I'm not really sure why?
 
Upvote 0
Anil

Have you stepped through the code using F8 and monitored what's happening?

That might give you a clue to the problem but having all those single letter variables might confuse things.

Do you actually need to those variables?

A lot of them seem to be used only once and even then they don't seem to be doing much.

For example here, why not just use .Cells(2,1).Value in the If statement?
Code: 
                        e = .Cells(2, 1).Value
                        If e <> "" Then
Can you tell us in words what the code is meant to do?

Obviously you are doing some sort of collation/consolidation but there seems to be something else going on.

I think that something is to do with where data is to go?
 
Upvote 0
@Rory:

I send you a message. I can't post the sheets here as its a violation of my Office.

@Norie:

Thanks for stopping by.

I used lot of variables as I am not good at VBA. Maybe I gotta start using Best Practises of writing programs.

Thanks
Anil
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Solved
Looking For Tips To Improve My VBA
Replies
8
Views
227
who am i
W
J
  • Solved
VBA Code Error Unable to get the Match property of the WorksheetFunction class
Replies
8
Views
364
Jiraya_00
J
R
  • Question Question
cells.find error handling
2
Replies
13
Views
588
jolivanes
jolivanes
M
  • Question Question
Paste to Headers
Replies
1
Views
173
mumps
mumps
M
  • Solved
VBA to delete cells from columns preceding the lowest value in the column
Replies
5
Views
113
DanteAmor
DanteAmor

Forum statistics

Threads
1,224,506
Messages
6,179,158
Members
452,892
Latest member
yadavagiri

Share this page

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