Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Grupa arkuszy - obsługa błędów

Dexter · Starszy Forumowicz Wersja: Win Office 365 Posty: 45

Cześć, mam takie oto makro:

Kod:

Sub Makro()

On Error Resume Next

Sheets(Array("Arkusz1", "Arkusz2", "Arkusz3")).Copy

...

Sheets(Array("Arkusz4", "Arkusz5", "Arkusz6")).Copy

...

On Error GoTo 0

End Sub

...rzecz w tym że wymienione arkusze nie zawsze będą istnieć. Jak w takim razie zrobić żeby kopiował tylko pozostałe/istniejące arkusze z grupy? Obsługa błędu jw. niestety nie działa.

Artik · Wysłany: 13-06-2024, 10:26

Tajan · **Pomógł:** 5633 razy Posty: 12168

Tak, grupowo, błędu obsłużyć się nie da. Należy użyć pętli i badać istnienie każdego arkusza oddzielnie. Jeżeli zależy nam na tym aby wykorzystać do tego obsługę błędów, to można to zrobić np. tak:

Kod:

Sub Makro()
Dim tenPlik As Workbook
Dim nowyPlik As Workbook
Dim arkusz As Worksheet
Dim nazwa

Set tenPlik = ActiveWorkbook

For Each nazwa In Array("Arkusz1", "Arkusz2", "Arkusz3")

On Error GoTo pominArkusz
Set arkusz = tenPlik.Sheets(nazwa)
On Error GoTo 0

If Not arkusz Is Nothing Then
If nowyPlik Is Nothing Then
arkusz.Copy
Else
With nowyPlik
arkusz.Copy after:=.Sheets(.Sheets.Count)
End With
End If
End If

Next

'...

Set nowyPlik = Nothing

For Each nazwa In Array("Arkusz4", "Arkusz5", "Arkusz6")

On Error GoTo pominArkusz
Set arkusz = tenPlik.Sheets(nazwa)
On Error GoTo 0

If Not arkusz Is Nothing Then
If nowyPlik Is Nothing Then
arkusz.Copy
Else
With nowyPlik
arkusz.Copy after:=.Sheets(.Sheets.Count)
End With
End If
End If

Next

'...

Exit Sub

pominArkusz:

Set arkusz = Nothing

Resume Next

End Sub

Oczywiscie, można cały kod testujący przenieść do oddzielnej procedury tym samym uprościć kod głównego makra. Np.:

Kod:

Sub kopiujArkusze(plik As Workbook, arkusze As Variant)

Dim nowyPlik As Workbook
Dim arkusz As Worksheet
Dim nazwa

For Each nazwa In arkusze

On Error GoTo pomin
Set arkusz = plik.Sheets(nazwa)
On Error GoTo 0

If Not arkusz Is Nothing Then
If nowyPlik Is Nothing Then
arkusz.Copy
set nowyPlik = ActiveWorkbook
Else
With nowyPlik
arkusz.Copy after:=.Sheets(.Sheets.Count)
End With
End If
End If

Next

Exit Sub

pomin:

Set arkusz = Nothing
Resume Next

End Sub

I wtedy główna procedura mogłaby wyglądać tak:

Kod:

Sub makro1()
Dim tenPlik As Workbook

Set tenPlik = ActiveWorkbook

kopiujArkusze tenPlik, arkusze:=Array("Arkusz1", "Arkusz2", "Arkusz3")

'...

kopiujArkusze tenPlik, arkusze:=Array("Arkusz4", "Arkusz5", "Arkusz6")

'...

End Sub

Edit: Istotna poprawka w procedurze "kopiujArkusze"

Maciej Gonet · Wysłany: 13-06-2024, 11:51

Ale wysyp propozycji. To jeszcze ja swoją dołożę.

Kod:

Sub CopySheets(arr)
Dim nm, arr1
arr1 = arr
On Error Resume Next
For Each nm In arr
If ThisWorkbook.Sheets(nm).Name = nm Then
If Err Then
Err.Clear
arr1 = Filter(arr1, nm, False, vbTextCompare)
End If
End If
Next nm
On Error GoTo 0
ThisWorkbook.Sheets(arr1).Copy
End Sub

Sub Main()
CopySheets Array("Arkusz1", "Arkusz2", "Arkusz3")
'...
CopySheets Array("Arkusz4", "Arkusz5", "Arkusz6")
End Sub

Moja propozycja zakłada, że nazwy arkuszy nie nakładają się tzn. np. nie będzie "Arkusz1" obok "Arkusz10".

Dexter · Starszy Forumowicz Wersja: Win Office 365 Posty: 45

Artik, Tajan,
Bardzo dziękuję Panowie! Obie opcje działają! :)

Maciej Gonet,
Ta opcja wydaje się najszybsza i również super działa :) Natomiast mógłbyś mi przybliżyć o co chodzi z "Moja propozycja zakłada, że nazwy arkuszy nie nakładają się tzn. np. nie będzie "Arkusz1" obok "Arkusz10"

To znaczy że jeśli arkusze byłyby obok siebie to coś nie zadziała? Operuję w tym przypadku na arkuszach o nazwach "literowych" bez cyfr. Chciałbym poznać ewentualne komplikacje z powodu użycia tej opcji.

master_mix · Wysłany: 13-06-2024, 13:21

gdyby było jednak, można Maćka kod przerobić:

Kod:

Function mySheets(ParamArray arr())

Dim nm, inx As Long, resArr()

On Error Resume Next
For Each nm In arr
With Worksheets(nm)
If Err.Number = 0 Then
ReDim Preserve resArr(inx)
resArr(inx) = nm
inx = inx + 1
Else
Err.Clear
End If
End With
Next
mySheets = resArr
End Function

Sub test()

Worksheets(mySheets("Arkusz1", "Arkusz10", "Arkusz6")).Select

End Sub

Dexter · Starszy Forumowicz Wersja: Win Office 365 Posty: 45

Maciej Gonet · Wysłany: 13-06-2024, 13:52

Moja propozycja wykorzystywała funkcję Filter, która jest szybka, ale działa na zasadzie usuwania wpisów pasujących do wzorca. Czyli jeśli jakiegoś arkusza wg podanej listy nie ma (jest błąd), to jego nazwa jest usuwana z listy, ale będą usuwane również nazwy obejmujące.
Powiedzmy, że na liście masz "Arkusz1", "Arkusz10". Ale "Arkusza1" nie ma w skoroszycie (a np. "Arkusz10" jest). Funkcja Filter usunie wszystko, co pasuje do wzorca "Arkusz1", a więc zarówno "Arkusz1" jak i "Arkusz10" bo nazwa "Arkusz1" jest zawarta wewnątrz nazwy "Arkusz10".

Jeśli tego rodzaju sytuacja może wystąpić, zastosuj propozycję master_mixa. On dodaje nazwy arkuszy po kolei do listy po sprawdzeniu, że jest, a nie usuwa gdy nie ma, jak u mnie.

Dexter · Starszy Forumowicz Wersja: Win Office 365 Posty: 45

master_mix, Maciej Gonet,

Super! Jeszcze raz bardzo dziękuję. Temat wyczerpany.