1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

  2. Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User


  3. When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

DO - While not working(Second Thread as no help from first)

Discussion in 'VBA Macros' started by Aman Semwal, Nov 8, 2018.

  1. Aman Semwal

    Aman Semwal Member

    Dear Team,

    Please view my code as my do while stops after first iteration :

    Screen Shot 2018-11-08 at 19.04.06.png
    Code (vb):

    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



    ActiveSheet.Range("$A$1:$AP$60000").RemoveDuplicates Columns:=1, Header:=xlNo
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    Cells(2, 13).Value = Trim(Cells(2, 13))

       wbk10.Close savechanges:=False
       Dim wbk101 As Workbook
    Dim X As Range

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

    Dim jj As Integer

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

        wbk101.Close savechanges:=False
        Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

    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

         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


    Set oMSOutlook = CreateObject("Outlook.Application")

    k = 2
    Set oEmail = oMSOutlook.CreateItem(olMailItem)
    On Error Resume Next

    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")
    End With
    On Error Resume Next

    Set oMSOutlook = Nothing
    Set oEmail = Nothing

         filename1 = Dir
         On Error Resume Next

    The breaking point of code is filename1 = Dir

    If I remove the attachment part i.e .Attachments.Add Pth & Dir(Pth & Cells(2, 5) & ".xlsb") the loop works which mean attachment should be done manually.

    Only I need a help where my loop work and the attachment is also done from the path given.

    Request you to please help me on this.
    Last edited by a moderator: Nov 8, 2018
  2. Kenneth Hobson

    Kenneth Hobson Active Member

    I don't know if it did not paste right but this should have a wildcard in the quotes?
    Code (vb):
    filename1 = Dir(path10 & "*")
    As for the attachments, what is the value in cells(2,5)? Even if it did return a filename in the Dir, concatenating ".xlsb" might not be needed. Even then, you did not check that the file exists in that pth before adding it as attachment.

    You can use Dir() to find if the file does exist.

    I would recommend avoiding Activate and Select when you can. Some of those double/triple lines can be converted to single line code. e.g.
    Code (vb):
    Sheets(2).Range("D2").PasteSpecial xlPasteValues, xlNone, False, False

Share This Page