Aman Semwal
Member
Dear Team,
Please view my code as my do while stops after first iteration :
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.
Please view my code as my do while stops after first iteration :
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: