Copy filtered data to temporary workbook and create email

[jackspade9]

Hello Excel Experts,
As I expected my code didn't work, lol.
Can you please check below command and please correct what I need to do.
The email part is working, but it fails when I inserted the if and do command.

I need to check if any in Column D (which is dates) are less than 30 days.
Then, copy the whole row to temporary workbook to create email.

Pleassssseeee help
Thank you

Private Sub CommandButton2_Click()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
row_number = 6

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

' ERROR HERE
Do
DoEvents
row_number = row_number + 1
item_searched = Sheets("Database").Range("D" & row_number)

If item_searched < 30 Then
With Destwb
Sourcewb.Sheets("Database").Rows.Range("A" & row_number).Copy.Sheets("Sheet1").Rows (row_number)

End With

End If
Loop Until item_searched = ""


Set Destwb = ActiveWorkbook

With Destwb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "You answered NO in the security dialog."
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " _
& Format(Now, "dd-mmm-yy h-mm-ss")

Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
' Change the mail address and subject in the macro before
' running the procedure.
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "List of Items will or Expired"
.Body = ""
.Attachments.Add Destwb.FullName
' You can add other files by uncommenting the following statement.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Display
End With
On Error GoTo 0
.Close Savechanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True


End With


End Sub

 

[Takae]

Sourcewb.Sheets("Database").Rows.Range("A" & row_number).Copy.Sheets("Sheet1").Rows (row_number)

It needs a space?
.Copy_.Sheets

However, this code is same as like this "Range("A1").copy Rows(10)" . This is not supposed to be correct.

 

[jackspade9]

Thank you Takae, I did it as per your comment above. I have no more error but it didn't create the detwb workbook and there is no email created. My mouse was just circling around. Can you please check it again. Thanks

Sourcewb.Sheets("Database").Rows.Range("A" & row_number).Copy Rows(row_number)

 

[Takae]

I overlooked "Rows" in "Sourcewb.Sheets("Database").Rows." sorry, it was not same as "Range("A1").copy Rows(10)" .

I am not able to get what you want to do in this lines....I just found no-space
--------
With Destwb
Sourcewb.Sheets("Database").Rows.Range("A" & row_number).Copy Rows(row_number) <--Changed
End With
-------

What is "Destwb"? It seems to be a workbook however you did not use "." in this line.
if it removed "Rows.", Sourcewb.Sheets("Database").Range("A" & row_number).Copy Rows(row_number) . It wil work but it means...

(row_number= row_number+1=7)
Sourcewb.Sheets("Database").Range("A7").copy Activesheet.range("A7:XFD7")