EXCEL macro - slanje maila za range - kako dodati print area?

[darijan...@gmail.com]

Pozdrav svima,

preko vba koda saljem excel tablice sa potrošnjom preko windows live
maila za redove koje imaju isti naziv maila u celiji. Dakle nešto
ovako:

ma...@mail.hr 100kn
ma...@mail.hr 200kn
ma...@mail.hr 500kn
ma...@mail.hr 300kn
ma...@mail.hr 160kn
itd......

Kod radi super i izgleda ovako:


Sub Send_Row_Or_Rows_Attachment_2()
'Working in 97-2010
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim I As Long

On Error GoTo cleanup

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

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1" & Ash.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start
in column A

'Add a worksheet for the unique list and copy the unique list in
A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1 ))

'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount

'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum,
1).Value

'Copy the visible data in a new workbook
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

Set NewWB = Workbooks.Add(xlWBATWorksheet)

rng.Copy
With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

'Create a file name
TempFilePath = Environ$("temp") & "\"
TempFileName = "Your data of " & Ash.Parent.Name _
& " " & Format(Now, "dd-mmm-yy h-mm-ss")

If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2010
FileExtStr = ".xls": FileFormatNum = -4143
End If

'Save, Mail, Close and Delete the file
With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
For I = 1 To 3
.SendMail Cws.Cells(Rnum, 1).Value, _
"Troškovi
mobilnog telefona 2012"
If Err.Number = 0 Then Exit For
Next I
On Error GoTo 0
.Close SaveChanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
End If

'Close AutoFilter
Ash.AutoFilterMode = False

Next Rnum
End If

cleanup:
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub


---------------------------------------------------------
No problem je u tome što mi ne podesi print area za svaki excel koji šalje i onda me korisnici zovu jer su preglupi da isprintaju na jednoj stranici podatke. Da li je moguće dodati u kod print area za svaki range koji šalje excel na mail? Nešto tipa ovo, samo neznam kako bih to modificirao i ubacio u kod i da li je to uopće ispravno:

Public Sub cusPrintArea()

Dim myRange As String

myRange = Selection.Address
ActiveSheet.PageSetup.PrintArea = myRange

On Error Goto 1
1: Exit Sub

With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With

ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

End Sub


Da li je to moguće u ubaciti, te na koji način?

Hvala

[b&s]

<darijan...@gmail.com> wrote in message
news:00da3f3c-394d-4b35...@googlegroups.com
> No problem je u tome ąto mi ne podesi print area za svaki
> excel koji ąalje i onda me korisnici zovu jer su preglupi

> da isprintaju na jednoj stranici podatke. Da li je moguće

> dodati u kod print area za svaki range koji ąalje excel
> na mail? Neąto tipa ovo, samo neznam kako bih to

> modificirao i ubacio u kod i da li je to uopće ispravno:

... ja bih nakon ovoga:

Set NewWB = Workbooks.Add(xlWBATWorksheet)
rng.Copy
With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

...dodao:

With NewWB.Sheets(1)
.PageSetup.PrintArea = NewWB.Sheets(1).UsedRange.Address
End With
With NewWB.Sheets(1)

.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1

End With

... ostali dio ostaje takav kakav je, ako te to zadovoljava.

... moľda prijedlog i pomogne ... ;-)

--
pozdrav!
Berislav
*******************************************************
Always nice to hear if a suggestion works or not.

[Darko Trkulja]

On May 30, 10:00 pm, "b&s" <b...@nema.me> wrote:
> <darijan.kre...@gmail.com> wrote in message

Radi! Hvala

[b&s]

"Darko Trkulja" <darkotr...@gmail.com> wrote in
message
news:671835e3-8934-4ebe...@w24g2000vby.googlegroups.com
> Radi! Hvala

... drago mi je da radi. Molim, i drugi put (ako zatreba ;-) )!

--
pozdrav!
Berislav