• 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...

  • 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)

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:
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:
I don't know if it did not paste right but this should have a wildcard in the quotes?
Code:
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:
Sheets(2).Range("D2").PasteSpecial xlPasteValues, xlNone, False, False
 
Back
Top