auto populate sheets

[scorpweb]

hi all,

my mate made some code for me a few months ago to auto populate data from 1 spreadsheet into a "log" so i can maintain all my data ....

however i need to expand this to about 7 spreadsheets now rather than 2 which he had set up

what i have so far:

Private Sub CommandButton1_Click()
    Dim ObjFolder
    Dim ObjFileCollection
    Dim ObjSubFolderCollection
    Dim ObjSubFolder
    Dim ObjFile
    Dim objFSO
    Dim xlapp
    Dim mwb As Workbook
    Dim cwb As Workbook
    Dim strsubfolderpath As String
    Dim rightcheck As Boolean
    Dim rightcheckpos As Integer
    strsubfolderpath = "C:\Users\MrLee\Documents\new pc\files"
   Set objFSO = CreateObject("Scripting.FileSystemObject")

   'Getting the folder
   Set ObjFolder = objFSO.GetFolder(strsubfolderpath)
   
   'Getting the list of files
   Set ObjFileCollection = ObjFolder.Files
   Set xlapp = Excel.Application
   Set mwb = xlapp.Workbooks.Open("C:\Users\MrLee\Documents\new pc\master\Master.xls")
   
   mwbpos1 = 1
   mwbpos2 = 2
   rightcheckpos = 1
   
   Do Until mwb.Worksheets(2).Cells(mwbpos1, 1).Value = ""
   mwbpos1 = mwbpos1 + 1
   Loop
   
   Do Until mwb.Worksheets(1).Cells(mwbpos2, 1).Value = ""
   mwbpos2 = mwbpos2 + 1
   Loop
   
   'Printing each file
   For Each ObjFile In ObjFileCollection
    rightcheck = True
   
    If LCase(Right(ObjFile.Name, 4)) = ".xls" Then
       Set cwb = xlapp.Workbooks.Open(ObjFile.Path)
       j = 3
       p = 3
       
restartloop:
       Do Until cwb.Sheets(2).Cells(j, 1).Value = ""
            
            For k = 1 To 6
            If cwb.Sheets(2).Cells(j, k).Value = 0 Then
                cwb.Worksheets(2).Cells(j, 12).Value = "Error - Cell " & k & " is empty"
                j = j + 1
                rightcheck = False
                GoTo restartloop
            End If
            Next k
            
            mwb.Worksheets(2).Rows(mwbpos1).Value = cwb.Worksheets(2).Rows(j).Value
            cwb.Worksheets(2).Rows(j).Delete
            mwbpos1 = mwbpos1 + 1
            
            
         
       Loop

restartloop2:

       Do Until cwb.Sheets(1).Cells(p, 1).Value = ""
            For q = 1 To 5
            If cwb.Sheets(1).Cells(p, 15).Value = "" Then
                cwb.Worksheets(1).Cells(p, 21).Value = "Error - Cell 15 is empty"
                p = p + 1
                rightcheck = False
                GoTo restartloop
            End If
            Next q
                     
            mwb.Worksheets(1).Rows(mwbpos2).Value = cwb.Worksheets(1).Rows(p).Value
            cwb.Worksheets(1).Rows(p).Delete
            mwbpos2 = mwbpos2 + 1

       Loop
    Application.DisplayAlerts = False
    If rightcheck = False Then
    Me.Cells(1, rightcheckpos).Value = ObjFile.Name
    rightcheckpos = rightcheckpos + 1
    End If
    cwb.Save
    cwb.Close
    Application.DisplayAlerts = True
      End If

    
    Next
     
    Application.DisplayAlerts = False
    mwb.Save
    mwb.Close
    Application.DisplayAlerts = True
    MsgBox "All Done!"
End Sub

i thought i'd have been able simply add

restartloop3:

       Do Until cwb.Sheets(3).Cells(p, 1).Value = ""
            For q = 1 To 5
            If cwb.Sheets(3).Cells(p, 15).Value = "" Then
                cwb.Worksheets(3).Cells(p, 21).Value = "Error - Cell 15 is empty"
                p = p + 1
                rightcheck = False
                GoTo restartloop
            End If
            Next q
                     
            mwb.Worksheets(3).Rows(mwbpos2).Value = cwb.Worksheets(3).Rows(p).Value
            cwb.Worksheets(3).Rows(p).Delete
            mwbpos2 = mwbpos2 + 1

       Loop

but it doesn't seem to work and debugs on:

        Do Until cwb.Sheets(3).Cells(p, 1).Value = ""

anyone able to shed any light on how i can expand this to more than the 2 sheets please?