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.

    Yours,
    Chandoo
  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

    Hui...

  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

    Messages:
    70
    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):

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

    Set oMSOutlook = Nothing
    Set oEmail = Nothing

       Sheets(3).Activate
         Range("A1:E100").Delete
     
         filename1 = Dir
     
         On Error Resume Next
     
         Loop

     
    The breaking point of code is filename1 = Dir

    Secondly,
    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

    Messages:
    225
    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