Jeszcze raz dzięki, co do nagłówka już sobie poradziłam (poniżej kod - dla zainteresowanych).
Code: Private Sub Dzielenie_Click()
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnStart As Range
Dim rnData As Range
Dim i As Long
Application.ScreenUpdating = False
On Error GoTo myErr
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Prowizja")
With wsSheet
Set rnData = .Range(.Range("A1"), .Cells(.Rows.Count, 1).End(xlUp)) 'zakres z danymi (z nagłowkiem)
Set rnFiltr = .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp)) 'zakres do filtrowania
End With
'tworzymy tablicę o mask. pojemności = ilości wierszy danych
Dim tabl() As String
ReDim tabl(1 To rnData.Rows.Count)
ile_w_tabl = 0
'dla każdej komórki z zakresu danych
For Each d In rnFiltr
wiersz = 1 ' od którego wiersza zaczynamy wyświetlać dane
dodaj = True
'szukamy czy już nie filtrowaliśmy po tej wartości
For i = 1 To ile_w_tabl
If tabl(i) = d Then 'jeżeli tak - przechodzimy dalej
dodaj = False
Exit For
End If
Next i
If dodaj = True Then
'dodajemy kolejną komórkę do tablicy
ile_w_tabl = ile_w_tabl + 1
tabl(ile_w_tabl) = CStr(d)
'tworzymy nowy arkusz
wbBook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = d
Set wsNowy = wbBook.Worksheets(CStr(d))
'nadanie nagłówka oraz ustawień strony
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = "&""Arial Baltic,Normalny""&8Nazwa jakaś" & Chr(10) & "tekst nowa linijka" & Chr(10) & "jeszcze jedna linijka"
.CenterHeader = "&""Arial Baltic,Pogrubiony""&10Zestawienie dla mnie " & CStr(d)
.RightHeader = "&D"
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.433070866141732)
.RightMargin = Application.InchesToPoints(0.196850393700787)
.TopMargin = Application.InchesToPoints(1.18110236220472)
.BottomMargin = Application.InchesToPoints(0.78740157480315)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
End With
'nadawanie nagłówka
'wbBook.Sheets(CStr(d)).Range("A1").Value = "Zestawienie prowizyjne dla Oddziału "
'wbBook.Sheets(CStr(d)).Range("A1").Font.Size = 14
'wbBook.Sheets(CStr(d)).Range("A1").Font.Bold = True
'kopiowanie nagłówka do nowego arkusza, A2- określa początek wyświetlania danych
wsSheet.Range("A1:O1").Copy Destination:=wbBook.Sheets(CStr(d)).Range("A1")
'filtrujemy po tej wartości: wyszukujemy kolejne w zakresie i kopiujemy je do nowego arkusza
Dim iLoop As Integer
Dim rCell As Range
Set rCell = rnData(1, 1) 'pierwsza komórka do przeszukiwania
ile_wyst = WorksheetFunction.CountIf(Columns(1), d)
For iLoop = 1 To ile_wyst
Set rCell = rnData.Columns(1).Find(What:=d, After:=rCell, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not rCell Is Nothing Then
wiersz = wiersz + 1
'kopiowanie danych do nowego arkusza dla danego zakresu
wsSheet.Range("A" & rCell.Row & ":O" & rCell.Row).Copy Destination:=wbBook.Sheets(CStr(d)).Range("A" & wiersz)
End If
Next iLoop
End If
Next d
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
MsgBox "Koniec", vbInformation + vbOKOnly, "OK"
On Error GoTo 0
Exit Sub
myErr:
Application.ScreenUpdating = True
MsgBox "Błąd podczas działania makra", vbCritical + vbOKOnly, "Błąd"
End Sub
Dodano po 39 [minuty]:
[Marcinj12] Sprawdziłam zamieszczone przez Ciebie makro, i niestety przy podaniu nowych zmiennych do filtrowania pojawia się komunikat o błędzie, następującej treści:
"Błąd podczas działania makra. Nie można nadać arkuszowi nazwy, którą posiada już inny arkusz, obiekt biblioteki lub skoroszyt, do którego występuje odwołanie w VBA".
Niestety nie wiem, dlaczego pojawia się komunikat, skoro nie ma innych plików o takiej nazwie otwartych, a dane zostały zmienione na nowe nazwy analogicznie do wcześniejszego zapisu.
Jedyna zmiana jaką dokonałam, to dodanie miejsca docelowego zapisu plików, co przy Twoich danych działało:
wbNowy.SaveAs Filename:="D:\Moje Dokumenty\Excel\test\Pliki\" & druga_kolumna & ".xls"
Dodano po 8 [minuty]:
Plik po zmianie danych w załączeniu. I przy okazji pytanie jak dynamicznie dodać podsumowanie w tym makro kolumny ?
Proszę pamiętać o używaniu znaczników code. - arnoldziq
$2 za prototyp PCBs
, tylko mam jakiś problem z kopiowaniem nagłówka. Dane przenoszą się do nowego arkusza, ale przy zapisywaniu pomijany jest nagłówek, pomimo że jak zauważyłam w kodzie jest kopiowany.
Pisałeś o podziale według dwóch kolumn A i B - przy takim założeniu musiały by to być niepowtarzające się pary.
