Do Until Loop Deletes and Creates New Sheet Instead of Skipping

[AlexB123]

Hi all,

I am revamping some code that aggregates data from several tabs of a workbook and copies them to another file, which is used as a link file in an Access Database.

When the code goes into a Do Until loop, it processes the data fine, unless there is a blank tab and then a final tab with some data on it. (I.e., in following, if Server tab "AA4" is blank, but there a is a row of data beneath the headers on the tab "AB1"). In this case, it deletes the existing "AB1" tab, creates a new "Sheet1", and then goes into debugging.

Anyone have an idea of what would cause this?

Thanks!

Sub Prepare()
    Dim fLink, fLinkShort, fmacro As String
    Dim myArray As Variant
    Dim wbLink, wbMacro As Workbook
    Dim wsLink As Worksheet
        
    Application.DisplayAlerts = False
    
    
    Set wbMacro = ThisWorkbook
    
    fLink = "C:\Me\TESTING\DBFiles\LNOVPSQLLink.xlsx"
    
    Set wbLink = Workbooks.Open(fLink)
    Set wsLink = wbLink.Worksheets("Sheet1")
    lastrow = wsLink.Rows.Range("b65536").End(xlUp).Row
    
    wsLink.Rows("2:" & lastrow).Delete
    myArray = Array("DBID", "Origin", "Code", "AMT", "RequestID", "PlanID", "Payroll", "SSN", "FirstName", "LastName", "Address1", "Address2", "City", "State", "Zip", "Comment1", "Comment2", "CashAccount")
    wsLink.Range("A1:R1").Value = myArray
    
    Dim server As String: server = ""
    wbMacro.Sheets.Add After:=wbMacro.Sheets(Sheets.Count)
    wbMacro.Sheets(8).Name = "ALL"
    
    Dim i As Integer: i = 1
    Do Until i = 7
        If i = 1 Then server = "AA1"
        If i = 2 Then server = "AA2"
        If i = 3 Then server = "AA3"
        If i = 4 Then server = "AA4"
        If i = 5 Then server = "AB1"
        If i = 6 Then server = "AB2"
        
        If wbMacro.Sheets(server).Range("b2").Value <> "" Then
            lastrow2 = wbMacro.Sheets(server).Rows.Range("b65536").End(xlUp).Row
   wbMacro.Sheets(server).Range("A2:U" & lastrow2).Copy
            lastrow3 = wbMacro.Sheets("ALL").Rows.Range("b65536").End(xlUp).Row
            wbMacro.Sheets("ALL").Range("A" & lastrow3 + 1).PasteSpecial
        End If
        i = i + 1
    Loop
    
    lastrow4 = wbMacro.Sheets("ALL").Rows.Range("a65536").End(xlUp).Row
    wbMacro.Sheets("ALL").Range("A2:T" & lastrow4).Copy
    
    wsLink.Range("A2").PasteSpecial
    
    wbLink.Save
    wbLink.Close False
    
    MsgBox "Operation complete!  Go to back to the database to update today's records."
    
    'save and archive
    '--------------------------------------------------------------------------------------------------------------
            Dim pathYearb As String: pathYearb = "C:\Me\TESTING\DBFiles\Archive\SQLResults\" & Year(Now())
            Dim pathFullb As String: pathFullb = pathYearb & "\" & MonthName(Month(Now))
            
            Call CheckPaths(pathYearb, pathFullb)
                
            wbMacro.SaveAs pathFullb & "\" & Format(Now(), "yyyy-mm-dd hh.nn.ss") & " SQL2 Results.xlsm"
    '--------------------------------------------------------------------------------------------------------------
    wbMacro.Close False
    Application.Quit
    
End Sub
Sub CheckPaths(sPath1 As String, sPath2 As String)
If Len(Dir(sPath1, vbDirectory)) = 0 Then
    MkDir (sPath1)
End If
If Len(Dir(sPath2, vbDirectory)) = 0 Then
    MkDir (sPath2)
End If
End Sub

 

[StephenCrump]

'Does it help if you replace:
wbMacro.Sheets.Add After:=wbMacro.Sheets(Sheets.Count)
wbMacro.Sheets(8).Name = "ALL"

'with
With wbMacro
    .Worksheets.Add(After:=.Sheets(.Sheets.Count)).Name = "ALL"
End With

 

[AlexB123]

That fixed my problem!!!

Thanks!!!