Sub dane()
Dim adresat As String
Dim temat As String
Dim tresc As String
Dim zalacznik1 As String
Dim zalacznik2 As String
On Error GoTo 0
adresat = Sheets("lista_mailingowa").Range("a5").Value
temat = Sheets("lista_mailingowa").Range("c5").Value
zalacznik1 = "C:\Users\Janusz\Desktop\" & Sheets("lista_mailingowa").Range("f5").Value _
& " " & Sheets("lista_mailingowa").Range("g5").Value & "_" & _
Sheets("lista_mailingowa").Range("h5").Value & ".txt"
zalacznik2 = "C:\Users\Janusz\Desktop\" & Sheets("lista_mailingowa").Range("f5").Value _
& " " & Sheets("lista_mailingowa").Range("g5").Value & "_" & _
Sheets("lista_mailingowa").Range("h5").Value & ".pdf"
podpis = Sheets("roboczy").Range("e5").Value
tresc = Sheets("wiadomosc").Range("a2").Value & podpis
tresc = Replace(tresc, "zmienna_imie", Sheets("lista_mailingowa").Range("b5").Value)
tresc = Replace(tresc, "zmienna_1", Sheets("lista_mailingowa").Range("d5").Value)
tresc = Replace(tresc, "zmienna_2", Sheets("lista_mailingowa").Range("e5").Value)
Call podglad(adresat, temat, tresc, zalacznik1, zalacznik2)
End Sub
Sub podglad(adresat As String, temat As String, tresc As String, zalacznik1 As String, zalacznik2 As String)
Dim myoutlook As Object
Dim mymsg As Object
On Error GoTo 0
Set myoutlook = CreateObject("Outlook.Application")
Set mymsg = myoutlook.createitem(0)
With mymsg
.To = adresat
.Subject = temat
.htmlbody = tresc
.Attachments.Add zalacznik1
.Attachments.Add zalacznik2
.display
End With
Set myoutlook = Nothing
Set mymsg = Nothing
End Sub
Sub aok()
Dim new_wb As Workbook
Dim First_empty_row As Range
Set First_empty_row = Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
Row(Rows.Count).End (xlUp)
tablica = ThisWorkbook.Sheets("Arkusz1").Range("a2:e9").Value
nazwa = gowno 'Sheets("lista_mailingowa").Range("g5").Value & " " & Sheets("lista_mailingowa").Range("f5").Value
'Debug.Print tablica(2, 1)
Set new_wb = Workbooks.Add
new_wb.Worksheets(1).Name = "plusy i minusy"
'wk.Worksheets(2).Delete
'wk.Worksheets(3).Delete
For i = 1 To 20
If tablica(i, 4) = "p" And tablica(i, 2) = Sheets("lista_mailingowa").Range("g5").Value & " " & Sheets("lista_mailingowa").Range("f5").Value Then
First_empty_row.Value = tablica(i, 5)
Else
End If
Next
End Sub
Option Explicit
Sub ParseItems()
'Jerry Beaucaire (4/22/2010)
'Based on selected column, data is filtered to individual workbooks
'workbooks are named for the value plus today's date
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String
Dim SvPath As String ' probably i will need this dim private
'Sheet with data in it
Set ws = Sheets("Arkusz1")
'Path to save files into, remember the final \
SAVE_PATH:
SvPath = Application.InputBox("Podaj ścieżkę do zapisu plików:", _
"Gdzie zapisać?", "C:\Users\Janusz\Desktop\", Type:=2)
If SvPath = "False" Then GoTo SAVE_PATH
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
vTitles = "A1:e1"
'Choose column to evaluate from, column A = 1, B = 2, etc.
vCol = Application.InputBox("Podaj kolumnę wg. której utworzyć pliki? " & vbLf _
& vbLf & "(A=1, B=2, C=3, itd.)", "Która kolumna?", 1, Type:=1)
If vCol = 0 Then Exit Sub
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Speed up macro execution
'Application.ScreenUpdating = False
'Get a temporary list of unique values from key column
ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True
'Sort the temporary list
ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Put list into an array for looping (values cannot be the result of formulas, must be constants)
MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))
'clear temporary worksheet list
ws.Range("EE:EE").Clear
'Turn on the autofilter, one column only is all that is needed
ws.Range(vTitles).AutoFilter
'Loop through list one value at a time
For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
ws.Range("A1:A" & LR).EntireRow.Copy
Workbooks.Add
Range("A1").PasteSpecial xlPasteAll
Cells.Columns.AutoFit
MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1
'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY"), xlNormal 'Excel 2003-
ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY") & ".xlsx", 51 'Excel 2007+
ActiveWorkbook.Close False
ws.Range(vTitles).AutoFilter Field:=vCol
Next Itm
'Cleanup
ws.AutoFilterMode = False
MsgBox "Wierszy z danymi: " & (LR - 1) & vbLf & "Przeniesionych wierszy: " & MyCount
Application.ScreenUpdating = True
End Sub