Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Zapisywanie arkuszy na podstawie listy

Ayala · ExcelGaduła 500+ Wersja: Win Office 2019 Posty: 503

Witam
Zastosowałem makro z innego projektu do zapisywania nowych arkuszy na podstawie listy pracowników.
Dla nowego pracownika działa dobrze.
Jednak gdy zmienię dane w arkuszu Grafik K1 oraz E3:E368 oraz G3:G368 to nie aktualizują się mi te dane w starych arkuszach wcześniej utworzonych.
Może jakiś pomysł jak to makro zmodyfikować.
Zastosowałem ale nie wszystko dla mnie jest jasne i nie potrafię tego zmienić.

Kod:

Sub KopiujArkusze()
Dim Rst As Object
Dim sht As Worksheet
Dim rng As Range
Dim nazwa As String
Dim nrArk As Long

Set rng = Sheets("Dane pracowników").Range("A1").CurrentRegion
Set Rst = RstFromRange(rng)

With Rst
.Sort = "Nazwisko, Imie ASC"
.MoveFirst
nrArk = 2
Do While Not .EOF
nazwa = Mid(!Nazwisko & " " & !Imie, 1, 31)
On Error Resume Next
Set sht = Sheets(nazwa)
On Error GoTo 0
If sht Is Nothing Then
Sheets("Grafik").Copy after:=Sheets(nrArk)
Set sht = ActiveSheet
sht.Name = nazwa
'sht.Range("G4") = ![Ulga podatkowa]
sht.Range("L2") = !Id_kalendarza
sht.Range("K1") = Worksheets("Grafik").Range("K1").Value '!Iden
'sht.Range("G3:G368") = Worksheets("Grafik").Range("G3:G368").Value '!Iden
End If
nrArk = sht.Index
Set sht = Nothing
.MoveNext
Loop
End With

Set Rst = Nothing

Call Grafik_Odkryj
End Sub

Private Function RstFromRange(oRng As Range) As Object
Dim oXML As Object

Set RstFromRange = CreateObject("ADODB.Recordset")
Set oXML = CreateObject("MSXML2.DOMDocument")

oXML.LoadXML oRng.Value(12)

RstFromRange.Open oXML

End Function

Pozdrawiam

Grafik 2023-01-18 test.xlsm

Pobierz Plik ściągnięto 7 raz(y) 326.42 KB

Tajan · **Pomógł:** 5234 razy Posty: 11412

Aby aktualizowały się wcześniej utworzone arkusze, to powinno być tak:

Kod:

Sub KopiujArkusze()
Dim Rst As Object
Dim sht As Worksheet
Dim rng As Range
Dim nazwa As String
Dim nrArk As Long

Set rng = Sheets("Dane pracowników").Range("A1").CurrentRegion
Set Rst = RstFromRange(rng)

With Rst
.Sort = "Nazwisko, Imie ASC"
.MoveFirst
nrArk = 2
Do While Not .EOF
nazwa = Mid(!Nazwisko & " " & !Imie, 1, 31)
On Error Resume Next
Set sht = Sheets(nazwa)
On Error GoTo 0

If sht Is Nothing Then
Sheets("Grafik").Copy after:=Sheets(nrArk)
Set sht = ActiveSheet
sht.Name = nazwa
End If

'sht.Range("G4") = ![Ulga podatkowa]
sht.Range("L2") = !Id_kalendarza
sht.Range("K1") = Worksheets("Grafik").Range("K1").Value '!Iden
sht.Range("B3:G368") = Worksheets("Grafik").Range("B3:G368").Value '!Iden

nrArk = sht.Index
Set sht = Nothing
.MoveNext
Loop
End With

Set Rst = Nothing

Call Grafik_Odkryj
End Sub

Ayala · ExcelGaduła 500+ Wersja: Win Office 2019 Posty: 503

Przy zapisywaniu arkuszy na podstawie listy nazwisk w komórce L1 nazwisko zapisuje się formułą.
Może dałoby się zmodyfikować makro, żeby nazwisko (z nazwy arkusza w komórce L1 zapisywało się jak wartość.

Kod:

Sub KopiujArkusze()
Dim Rst As Object
Dim sht As Worksheet
Dim rng As Range
Dim nazwa As String
Dim nrArk As Long

Set rng = Sheets("Dane pracowników").Range("A1").CurrentRegion
Set Rst = RstFromRange(rng)

With Rst
.Sort = "Nazwisko, Imie ASC"
.MoveFirst
nrArk = 3 '2
Do While Not .EOF
nazwa = Mid(!Nazwisko & " " & !Imie, 1, 31)
On Error Resume Next
Set sht = Sheets(nazwa)
On Error GoTo 0

If sht Is Nothing Then
Sheets("Grafik").Copy after:=Sheets(nrArk)
Set sht = ActiveSheet
sht.Name = nazwa
End If

'sht.Range("G4") = ![Ulga podatkowa]
sht.Range("L2") = !Id_kalendarza
sht.Range("K1") = Worksheets("Grafik").Range("K1").Value '!Iden
sht.Range("B3:G368") = Worksheets("Grafik").Range("B3:G368").Value '!Iden

nrArk = sht.Index
Set sht = Nothing
.MoveNext
Loop
End With

Set Rst = Nothing

Call GoToGrafik
End Sub

Formuła w komórce L1 przeszkadza w działaniu natępnych kodów.
Może jakiś pomysł na rozwiązanie tego problemu

Grafik_test.xlsm

Pobierz Plik ściągnięto 8 raz(y) 316.18 KB

Ayala · ExcelGaduła 500+ Wersja: Win Office 2019 Posty: 503

Problem z formułą opanowałem
Chciałbym jeszcze zmienić wybieranie nazwisk z imieniem z jednej kolumny Nazwisko_Imie.
Może jakaś podpowiedź co trzeba zmienić w kodzie

Kod:

Sub KopiujArkusze()
Dim Rst As Object
Dim sht As Worksheet
Dim rng As Range
Dim nazwa As String
Dim nrArk As Long

Set rng = Sheets("Nazwiska").Range("A1").CurrentRegion
Set Rst = RstFromRange(rng)

With Rst
.Sort = "Nazwisko, Imie ASC"

.MoveFirst
nrArk = 3 '2
Do While Not .EOF
nazwa = Mid(!Nazwisko & " " & !Imie, 1, 31)

On Error Resume Next
Set sht = Sheets(nazwa)
On Error GoTo 0

If sht Is Nothing Then
Sheets("Grafik").Copy after:=Sheets(nrArk)
Set sht = ActiveSheet
sht.Name = nazwa
End If

'sht.Range("G4") = ![Ulga podatkowa]
sht.Range("L1") = nazwa '!nazwisko i imię
sht.Range("L2") = !Id_kalendarza
sht.Range("K1") = Worksheets("Grafik").Range("K1").Value '!Iden
sht.Range("B3:G368") = Worksheets("Grafik").Range("B3:G368").Value '!Iden

nrArk = sht.Index
Set sht = Nothing
.MoveNext
Loop
End With

Set Rst = Nothing

Call GoToGrafik
End Sub

Nazwisko i imię zapisane będzie w kolumnie B.
Będę wdzięczny za podpowiedź

Pozdrawiam
Ayala

Grafik 2023-01-20.xlsm

Pobierz Plik ściągnięto 11 raz(y) 180.51 KB

Tajan · **Pomógł:** 5234 razy Posty: 11412

Zmień zgodnie z nazwa pola:

Kod:

nazwa = Mid(!Nazwisko & " " & !Imie, 1, 31)

na:

Kod:

nazwa = Mid(!Nazwisko_imie, 1, 31)

i ewentualnie, jeżeli nie będzie osobnych pól Nazwisko oraz Imie, to:

Kod:

.Sort = "Nazwisko, Imie ASC"

na:

Kod:

.Sort = "Nazwisko_imie ASC"

W razie potrzeby, można też zmienić:

Kod:

sht.Range("L1") = nazwa '!nazwisko i imię

na

Kod:

sht.Range("L1") = !Nazwisko_imie

Ayala · ExcelGaduła 500+ Wersja: Win Office 2019 Posty: 503

Dziękuję
Wszystko działa jak należy.

Robiłem podobnie, ale zostawiałem dodatkowe kolumny z Nazwiskiem i Imieniem z formułami rozdzielającymi nazwisko imię i to to było przeszkodą. Po usunięciu tych formuł problem zniknął.
Nie wiem czemu to nie działa przecież nie odwołuję się do tych dodatkowych kolumn.

Jeszcze raz dziękuję.
:clap

Pozdrawiam
Ayala