Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 75911 Skopiuj do schowka Grupa arkuszy - obsługa błędów
Autor Wiadomość
Dexter 
Starszy Forumowicz



Wersja: Win Office 365
Posty: 38
Wysłany: 13-06-2024, 01:16   Grupa arkuszy - obsługa błędów

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.
_________________
Quantum scimus, gutta est, ignoramus mare...
ID posta: 435801 Skopiuj do schowka
 
 
Artik 
Artik



Wersja: Win Office 365
Pomógł: 3256 razy
Posty: 10762
Wysłany: 13-06-2024, 10:26   

Dexter napisał/a:
Obsługa błędu jw. niestety nie działa.
Gwoli ścisłości. Obsługa błędów działa, tylko nie ma oczekiwanych wyników. Jeżeli nie ma któregoś z arkuszy wymienionych w tablicy, to wtenczas cała grupa jest ignorowana.

Myślę, że trzeba badać, które arkusze istnieją i tylko te dodawać do grupy.
Naprędce stworzony kod:
Kod:
Sub Test()
    Dim varrShts As Variant
    Dim strShts As String

    strShts = "Arkusz1,Arkusz2,Arkusz3"
    varrShts = ExistingSheets(ActiveWorkbook, Split(strShts, ","))

    If UBound(varrShts) >= 0 Then
        Sheets(varrShts).Copy
    End If

    '(...)

    strShts = "Arkusz4,Arkusz5,Arkusz6"
    varrShts = ExistingSheets(ActiveWorkbook, Split(strShts, ","))

    If UBound(varrShts) >= 0 Then
        Sheets(varrShts).Copy
    End If

    '(...)

End Sub


Function ExistingSheets(wkb As Workbook, ParamArray Shts()) As Variant
    Dim Sh As Object
    Dim i As Long
    Dim oDic As Object

    Set oDic = CreateObject("Scripting.Dictionary")

    On Error Resume Next

    For i = LBound(Shts(0)) To UBound(Shts(0))
        Err.Clear
        Set Sh = wkb.Sheets(CStr(Shts(0)(i)))
        If Not Sh Is Nothing Then
            oDic.Add Shts(0)(i), 0
        End If
        Set Sh = Nothing
    Next i

    ExistingSheets = oDic.Keys()

End Function

Artik
_________________
Persistence is a virtue in the world of programming.
Weryfikator NIP - szybka, masowa weryfikacja w MF i VIES.
ID posta: 435807 Skopiuj do schowka
 
 
Tajan


Pomógł: 5480 razy
Posty: 11920
Wysłany: 13-06-2024, 10:37   

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"
Ostatnio zmieniony przez Tajan 13-06-2024, 12:08, w całości zmieniany 2 razy  
ID posta: 435808 Skopiuj do schowka
 
 
Maciej Gonet 
Excel Expert


Wersja: Win Office 365
Pomógł: 3469 razy
Posty: 10236
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".
ID posta: 435809 Skopiuj do schowka
 
 
Dexter 
Starszy Forumowicz



Wersja: Win Office 365
Posty: 38
Wysłany: 13-06-2024, 13:11   

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.
_________________
Quantum scimus, gutta est, ignoramus mare...
ID posta: 435812 Skopiuj do schowka
 
 
master_mix 
Excel Expert



Wersja: Win Office 365
Pomógł: 1292 razy
Posty: 2625
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
_________________

Podejmę współpracę (pracę)
Programowanie C#, Android, iOS, VB.NET, VBA, ASP.NET Core, WPF, Xamarin, Power Platforms, XAML, MVC, LINQ, Entity Framework. Bazy danych SQL Server, Oracle, MySQL, Firebird
Wrocław i okolice …lub zdalnie.
ID posta: 435813 Skopiuj do schowka
 
 
Dexter 
Starszy Forumowicz



Wersja: Win Office 365
Posty: 38
Wysłany: 13-06-2024, 13:43   

master_mix napisał/a:
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


Jakaś istotna różnica w działaniu? Proszę o informację :)
_________________
Quantum scimus, gutta est, ignoramus mare...
ID posta: 435815 Skopiuj do schowka
 
 
Maciej Gonet 
Excel Expert


Wersja: Win Office 365
Pomógł: 3469 razy
Posty: 10236
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.
ID posta: 435816 Skopiuj do schowka
 
 
Dexter 
Starszy Forumowicz



Wersja: Win Office 365
Posty: 38
Wysłany: 13-06-2024, 14:02   

master_mix, Maciej Gonet,

Super! Jeszcze raz bardzo dziękuję. Temat wyczerpany.
_________________
Quantum scimus, gutta est, ignoramus mare...
ID posta: 435817 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.wip.pl

Archiwum

Strona uĹźywa plikĂłw cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przegl�darce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
SprawdĹş, w jaki sposĂłb przetwarzamy dane osobowe