Macro to copy and paste dynamically changing sheets

[ksghumaria]

I have a if-elseif condition that give different sheet after operation(when the loop is runned). I want to copy this sheet as a new workbook, save as temp, email and delete. Need help with the code.

Basically want the active sheet to be copied every time.

Sub Send_sheet()

[COLOR=#333333]Dim OutApp As Object[/COLOR]
[COLOR=#333333]Dim OutMail As Object[/COLOR]
[COLOR=#333333]Dim rng As Range[/COLOR]
[COLOR=#333333]Dim DataWB As Worksheet[/COLOR]
[COLOR=#333333]Dim Cws As Worksheet[/COLOR]
[COLOR=#333333]Dim Rcount As Long[/COLOR]
[COLOR=#333333]Dim Rnum As Long[/COLOR]
[COLOR=#333333]Dim FilterRange As Range[/COLOR]
[COLOR=#333333]Dim FieldNum As Integer[/COLOR]
[COLOR=#333333]Dim NewWB As Workbook[/COLOR]
[COLOR=#333333]Dim TempFilePath As String[/COLOR]
[COLOR=#333333]Dim TempFileName As String[/COLOR]
[COLOR=#333333]Dim FileExtStr As String[/COLOR]
[COLOR=#333333]Dim FileFormatNum As Long[/COLOR]
[COLOR=#333333]Dim k As Worksheet[/COLOR]
[COLOR=#333333]Dim product[/COLOR]

[COLOR=#333333]On Error GoTo cleanup[/COLOR]
[COLOR=#333333]Set OutApp = CreateObject("Outlook.Application")[/COLOR]

[COLOR=#333333]With Application[/COLOR]
[COLOR=#333333].EnableEvents = False[/COLOR]
[COLOR=#333333].ScreenUpdating = True[/COLOR]

[COLOR=#333333]End With[/COLOR]

[COLOR=#333333]Set DataWB = Sheets("DATA")[/COLOR]
[COLOR=#333333]Set FilterRange = DataWB.Range("A1:K" & DataWB.Rows.Count)[/COLOR]
[COLOR=#333333]FieldNum = 2 'Filter column = B because the filter range start in column A[/COLOR]

[COLOR=#333333]Set Cws = Worksheets.Add[/COLOR]
[COLOR=#333333]Cws.Name = "Email IDs"[/COLOR]

[COLOR=#333333]FilterRange.Columns(FieldNum).AdvancedFilter _[/COLOR]
[COLOR=#333333]Action:=xlFilterCopy, _[/COLOR]
[COLOR=#333333]CopyToRange:=Cws.Range("A1"), _[/COLOR]
[COLOR=#333333]CriteriaRange:="", Unique:=True[/COLOR]

[COLOR=#333333]Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))[/COLOR]
[COLOR=#333333]If Rcount >= 2 Then[/COLOR]
[COLOR=#333333]For Rnum = 2 To Rcount[/COLOR]
[COLOR=#333333]product = Sheets("DATA").Cells(Rnum, 4)[/COLOR]
[COLOR=#333333]'If the unique value is a mail addres create a mail[/COLOR]
[COLOR=#333333]If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then[/COLOR]


[COLOR=#333333]FilterRange.AutoFilter Field:=FieldNum, _[/COLOR]
[COLOR=#333333]Criteria1:=Cws.Cells(Rnum, 1).Value[/COLOR]


[COLOR=#333333]With DataWB.AutoFilter.Range[/COLOR]
[COLOR=#333333]On Error Resume Next[/COLOR]
[COLOR=#333333]'MsgBox (product)[/COLOR]
[COLOR=#333333]If product = 1000 Or product = 3000 Then[/COLOR]
[COLOR=#333333]Sheets("A").Select[/COLOR]
[COLOR=#333333]ElseIf product = 2000 Then[/COLOR]
[COLOR=#333333]Sheets("B").Select[/COLOR]
[COLOR=#333333]ElseIf product = 4000 Then[/COLOR]
[COLOR=#333333]Sheets("C”).Select[/COLOR]
[COLOR=#333333]End If[/COLOR]
[COLOR=#333333]Range("C5").Value = Sheets("DATA").Cells(Rnum, 1).Value[/COLOR]
[COLOR=#333333]Range("C6").Value = Sheets("DATA").Cells(Rnum, 3).Value[/COLOR]
[COLOR=#333333]Range("C9").Value = Sheets("DATA").Cells(Rnum, 7).Value[/COLOR]
[COLOR=#333333]Range("C12").Value = Sheets("DATA").Cells(Rnum, 5).Value[/COLOR]
[COLOR=#333333]Range("E16").Value = Sheets("DATA").Cells(Rnum, 8).Value[/COLOR]
[COLOR=#333333]Range("E18").Value = Sheets("DATA").Cells(Rnum, 9).Value[/COLOR]
[COLOR=#333333]Range("E19").Value = Sheets("DATA").Cells(Rnum, 10).Value[/COLOR]
[COLOR=#333333]Range("E23").Value = Sheets("DATA").Cells(Rnum, 11).Value[/COLOR]
[COLOR=#333333]Range("I18").Value = 12[/COLOR]
[COLOR=#333333]k = ActiveSheet.copy[/COLOR]
[COLOR=#333333]On Error GoTo 0[/COLOR]
[COLOR=#333333]End With[/COLOR]

[U]NewWB = Workbook.Add[/U][COLOR=#333333] ' showing error[/COLOR]

[B][U]T[/U][/B][B][U]hisWorkbook.Sheets.k.Copy before:=NewWB.Sheets(1)[/U] 'showing error[/B][B]
Application.CutCopyMode = False
Range("A4").Select
ActiveWindow.FreezePanes = True

TempFilePath = Environ$("temp") & "\"
TempFileName = Data[/B][B]WB.Parent.Name _
& " " & Format(Now, "dd-mmm-yy h-mm-ss")

If Val(Application.Version) < 12 Then

FileExtStr = ".xls": FileFormatNum = -4143
Else

FileExtStr = ".xlsx": FileFormatNum = 51
End If


Set OutMail = OutApp.CreateItem(0)

With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = Cws.Cells(Rnum, 1).Value
.Subject = "XYZABC12345"
.Attachments.Add NewWB.FullName
.Body = "Hello Everyone”
.display
End With
On Error GoTo 0
.Close savechanges:=False
End With

Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If


DataWB.AutoFilterMode = False

Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Su[/B][B]b[/B]

 

[MARK858]

Deleted as more errors to look at.

 

[ksghumaria]

Need help with the copy-paste part of the code.

 

[MARK858]

Try changing

Dim k As Worksheet

to

Dim k As String

then change

k = ActiveSheet.copy
On Error GoTo 0
End With

NewWB = Workbook.Add ' showing error

ThisWorkbook.Sheets.k.Copy before:=NewWB.Sheets(1)

to

On Error GoTo 0
End With
k = ActiveSheet.Name

Set NewWB = Workbooks.Add 

ThisWorkbook.Sheets(k).Copy before:=NewWB.Sheets(1)

Not sure why you would want to copy before Sheet1 on a brand new workbook though. Each to their own though

 

[ksghumaria]

Since you mentioned, I think you have a relevant point. Is there a way to only keep this sheet in the NewWB?

 

[MARK858]

Just unusual to use before rather than after. If you want the sheet to go in the current 1st sheet in the new workbook try..

ThisWorkbook.Sheets(k).Cells.Copy NewWB.Sheets(1).Cells(1, 1)

 

[ksghumaria]

Thanks for the help.
My issues are solved.