Copying Array Contents into Cells. Gathering data from sheets and compiling into 1.

Hi,

I've been given the task of automating a spreadsheet to assess whether work has been done by each employee.

Every employee has their own spreadsheet, where column A is a job code, and column H contains either y or n dentoting whether they have completed the task (y) or not (n).

The main spreadsheet is designed to show any outstadning tasks across everybody so it has a list of everybodies names in column A and then any incomplete tasks will be listed from columns b onwards next to the appropriate person.

Here is what I have done at the moment.

Sub pop_report()
Dim vaCells(1 To 30)								' Set array length = 30
numberofemployees = Sheets("Report_Standard").Range("D4").Value			' Read no. of employees from excel cell

For a = 1 To numberofemployees							' Start at first employee, finish at last
e = 1										' Set array number to 1
        rownumber = a + 16							' 15 rows above start of employee list, so a + 16 gives 1st employee
        empname = Cells(rownumber, 1).Value							'employee name in column A
        emprow = Application.Match(empname, Worksheets("Employee List").Columns(2), 0)		'find employee name in employee database sheet
        emppath = Sheets("Employee List").Cells(emprow, 3).Value				'on that sheet find the path to their file
        empfile = Sheets("Employee List").Cells(emprow, 4).Value				'on that sheet find filename of their file
        empfullpath = emppath & empfile								'combine for full path
        Workbooks.Open (empfullpath)								'open employee sheet
        b = 11											'set b (row number in employee sheet to 11
        


Do While c = 0											'keep looping until c becomes anything but 0
        b = b + 1										'Inc. b
        
        If Workbooks(empfile).Worksheets(1).Cells(b, 1) <> "" Then				'If workcode isnt blank
                If Workbooks(empfile).Worksheets(1).Cells(b, 16).Value <> "y" And Workbooks(empfile).Worksheets(1).Cells(b, 16).Value <> "Y" Then	'If work has not been completed
                        vaCells(e) = Workbooks(empfile).Worksheets(1).Cells(b, 1).Value		' store workcode in array position e
                        e = e + 1								' increment e
                        GoTo loopnow								' loop
                Else	
                        GoTo loopnow								' if work has been completed, loop
                End If
        Else
                d = d + 1									' If work code is blank then increment blankcounter
                GoTo loopnow									' ... then loop
        End If


GoTo loopnow
loopnow:
If d > 10 Then c = 1										' If there have been 10 blanks in a row, then end looping

Loop												' If not then loop

    Workbooks("NCR_tracking_sheet V101.xls").Worksheets("SICAM SAS 2009").Range("B17:AE17") = Application.Transpose(vaCells)		' Write array into horizontal cells from B17 onwards


Next a												' Next employee
End Sub

The "If d > 10 Then c = 1" is because sometimes there will be gaps in the list I have been told that if there are 10 gaps in a row I can assume it is the end of the list. If there is a better way of telling that there is no more data in any cells below then the list is ended I would be glad to hear it.


Currently the code semi works but when it outputs I get just the first outstanding job code repeated along the row????

Any ideas????????????

Thanks.

Wouldn't confess to having looked at this in great depth but perhaps:

Sub pop_report()
' Set array length = 30
Dim vaCells(1 To 30)
Dim numberofemployees As Long, a As Long, e As Long, rownumber As Long, b As Long
Dim emprow As Variant
Dim empname As String, emppath As String, empfile As String, empfullpath As String
' Read no. of employees from excel cell
numberofemployees = Sheets("Report_Standard").Range("D4").Value
' Start at first employee, finish at last
For a = 1 To numberofemployees
    ' Set array number to 1
    e = 1
    ' 15 rows above start of employee list, so a + 16 gives 1st employee
    rownumber = a + 16
    'employee name in column A
    empname = Cells(rownumber, 1).Value
    'find employee name in employee database sheet
    emprow = Application.Match(empname, Worksheets("Employee List").Columns(2), 0)
    'on that sheet find the path to their file
    emppath = Sheets("Employee List").Cells(emprow, 3).Value
    'on that sheet find filename of their file
    empfile = Sheets("Employee List").Cells(emprow, 4).Value
    'combine for full path
    empfullpath = emppath & empfile
    'open employee sheet
    Workbooks.Open (empfullpath)
    'keep looping until c becomes anything but 0
    For b = 11 To Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row Step 1
        'If workcode isnt blank
        If Workbooks(empfile).Worksheets(1).Cells(b, 1) <> "" Then
            'If work has not been completed
            If UCase(Worksheets(1).Cells(b, 16).Value) <> "Y" Then
                ' store workcode in array position e
                vaCells(e) = Worksheets(1).Cells(b, 1).Value
                ' increment e
                e = e + 1
            End If
        End If
    Next b
    ' Close File
    ActiveWorkbook.Close False
    ' Write array into horizontal cells from B17 onwards
    Workbooks("NCR_tracking_sheet V101.xls").Worksheets("SICAM SAS 2009").Range("B17:AE17") = Application.Transpose(vaCells)
    ' Next employee
Next a
End Sub

The codes a lot neater obviously, and thanks for showing me how to do search for upper and lowercase Y.

But still not working, all I get is the very first job code repeated across b,c,d.... etc whereas it should show the first part of the array in b, the second in c etc etc

I also had to fiddle with a few bits to make it source from the open spreadsheet, it kept defaulting to sourcing from the main sheet.


Here is the code as it stands:

Sub pop_reportnew()
' Set array length = 30
Dim vaCells(1 To 30)
Dim numberofemployees As Long, a As Long, e As Long, rownumber As Long, b As Long
Dim employeerow As Variant
Dim employeename As String, employeepath As String, employeefile As String, employeefullpath As String
' Read no. of employees from excel cell
numberofemployees = Sheets("Report_Standard").Range("D4").Value
' Start at first employee, finish at last
For a = 1 To 1
    ' Set array number to 1
    e = 1
    ' 15 rows above start of employee list, so a + 16 gives 1st employee
    rownumber = a + 16
    'employee name in column E
    employeename = Cells(rownumber, 5).Value
    'find employee name in employee database sheet
    employeerow = Application.Match(employeename, Worksheets("employee List").Columns(2), 0)
    'on that sheet find the path to their file
    employeepath = Sheets("employee List").Cells(employeerow, 3).Value
    'on that sheet find filename of their file
    employeefile = Sheets("employee List").Cells(employeerow, 4).Value
    'combine for full path
    employeefullpath = employeepath & employeefile
    'open employee sheet
    Workbooks.Open (employeefullpath)
    'keep looping until c becomes anything but 0
    For b = 12 To 120
        'If workcode isnt blank
        If Workbooks(employeefile).Worksheets(1).Cells(b, 1) <> "" Then
            'If work has not been completed
            If UCase(Workbooks(employeefile).Worksheets(1).Cells(b, 16).Value) <> "Y" Then
                ' store workcode in array position e
                vaCells(e) = Workbooks(employeefile).Worksheets(1).Cells(b, 1).Value
                ' increment e
                e = e + 1
            End If
        End If
    Next b
    ' Close File
    ActiveWorkbook.Close False
    ' Write array into horizontal cells from B17 onwards
    Workbooks("NCR_tracking_sheet V101.xls").Worksheets("SICAM SAS 2009").Range("G17:AJ17") = Application.Transpose(vaCells)
    ' Next employee
Next a
End Sub