Do While” Loop Not functioning correctly after first iteration

[Aman Semwal]

Here is my code :

>>> use CODE -tags <<<

Worksheets(2).Activate
Range("K2").Value = q
Range("P2").Value = q

Range("S2").Value = p



Dim xws1 As Workbook
Dim wbk10 As Workbook
Dim filename1 As String
Dim path10 As String

Set xws1 = Application.ActiveWorkbook


path10 = "I:\PROJECTS\mds\INPUT FILES\"
filename1 = Dir(path10 & "")
'--------------------------------------------
'wbk10 is the extract TMC file
'It opens one by one and will give output

Do While filename1 <> ""
    Set wbk10 = Workbooks.Open(path10 & filename1)

'xws1 file gets activate and value are automatically gets paste on the file

    wbk10.Activate

Columns("A:A").Select

ActiveSheet.Range("$A$1:$AP$60000").RemoveDuplicates Columns:=1, Header:=xlNo
    Range("A2:A20").Select
    Selection.Copy
    xws1.Activate
    Sheets("Sheet2").Select
    Range("A2").Select
    ActiveSheet.Paste
wbk10.Activate
Range("C2").Select
Selection.Copy
xws1.Activate
Sheets(2).Select
Range("M2").Select
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Cells(2, 13).Value = Trim(Cells(2, 13))
 
   wbk10.Activate
   wbk10.Close savechanges:=False
      xws1.Activate
   Dim wbk101 As Workbook
Dim X As Range

Set wbk101 = Workbooks.Open("I:\Corp\BTA\PROJECTS\Statement\Kzoo Report\BTA\BTA.xlsx")
    Set X = wbk101.Worksheets("Sheet1").Range("E:AA")


Dim j As Integer

    With xws1.Sheets(3)
        For j = 2 To 20
            .Cells(j, 2) = Application.VLookup(.Cells(j, 1).Value2, X, 23, False)
         
        Next j
    End With

    wbk101.Close savechanges:=False
xws1.Activate
     xws1.Sheets(3).Select
     Columns("B:B").Select
    Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
Columns("b:b").Select

ActiveSheet.Range("$b$1:$b$60000").RemoveDuplicates Columns:=1, Header:=xlNo
 
On Error Resume Next
   
     Cells(2, 3) = Cells(2, 2) & ";" & Cells(3, 2) & ";" & Cells(4, 2) & ";" & Cells(5, 2) & ";" & Cells(6, 2) & ";" & Cells(7, 2) & ";" & Cells(8, 2) & ";" & Cells(9, 2) & ";" & Cells(10, 2) & ";" & Cells(11, 2) & ";" & Cells(12, 2) & ";" & Cells(13, 2)
On Error Resume Next
   

Cells(2, 3).Copy

     Sheets(2).Select
     Range("D2").Select
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

     Dim oMSOutlook As Object
Dim oEmail As Object
Dim k As Integer
Dim strBody As String
'Dim Pth As String


'Pth = "I:\PROJECTS\mds\OUTPUT FILES\"

Set oMSOutlook = CreateObject("Outlook.Application")

k = 2
Set oEmail = oMSOutlook.CreateItem(olMailItem)

With oEmail
.SentOnBehalfOfName = "semwal.aman21@gmail.com"
.To = Cells(k, 4)
.Cc = Cells(k, 2)
.Subject = Cells(k, 5)
.Body = Cells(k, 3)
'.Attachments.Add Pth & Dir(Pth & Cells(2, 5) & ".xlsb")
.Save
End With

Set oMSOutlook = Nothing
Set oEmail = Nothing
 
   Sheets(3).Activate
     Range("A1:E100").Delete
 
 
filename1 = Dir
Loop

Please help me as do while stop after first iteration.

 

[AlanSidman]

Have you debugged your code by stepping through it to see what happens that causes it to not loop.

I cannot do that as I do not have your worksheet/book to validate the code against.

Look at this link on debugging
http://www.cpearson.com/excel/DebuggingVBA.aspx

 

[Aman Semwal]

It run only the first time but doesn't loop for second time.

The loop runs if I avoid the attachment path code in my loop.

 

[Hui]

Put a line
On Error Resume Next

before the With Email line

 

[Aman Semwal]

Sharing the attached demo file as template.

I tried to run with on error resume next but still it does not loop.

In case I do not use the attachment code :.Attachments.Add Pth & Dir(Pth & Cells(2, 5) & ".xlsb") then it gets loop but if I use the code then it does not loop. It just stops after running the first workbook only.

 

[Aman Semwal]

Somebody who can help me with this

 

[Aman Semwal]

?