Excel VBA : Tworzenie, kopiowanie i nazywanie dynamiczne arkuszy

Dynamic Kolejne wyzwanie Visual Basic For Application dla Excela mnie spotkało. Czy można w Excelu dynamicznie wygenerować arkusze, które są kopią istniejącego arkusza? Oczywiście, że tak.

Czy można nadać nazwę według pewnego wzoru tym arkuszom? Tak

Oto zadanie, które miałem wykonać. Mam więc arkusz do kopiowania wygląda on tak.

Każda kopia takiego arkusza musi mieć swoją nazwę według pewnego wzoru. Oto moja tabelka. 

Zanim więc przejdziemy do generowania takich arkuszy musi najpierw określić kod nazwy. Jego wzór jest następujący 

"4 pierwsze litery z miasta" + "_" + "Ostatnia cyfra z Numer1" + "_" + "Pierwsza cyfra z Numer 2" + "_" + "Kod Regionu"

Kod VBA, który takie napisy wygeneruje wygląda tak:

Sub DajKodDoArkuszu()

For x = 2 To 9
    
    Dim cellcity, cellnumber1, cellnumeber2, cellregion As String
    
    cellcity = "B" & x
    cellnumber1 = "C" & x
    cellnumeber2 = "D" & x
    cellregion = "E" & x
    
    Dim vcity, vnumber1, vnumber2, vregion As String
    
    vcity = Range(cellcity).Value
    vnumber1 = Range(cellnumber1).Value
    vnumber2 = Range(cellnumeber2).Value
    vregion = Range(cellregion).Value
       
    Dim lenghtcity
    lenghtcity = Len(vcity)
    
    If lenghtcity > 4 Then
        vcity = Left(vcity, 4)
    End If
    
    vnumber1 = Right(vnumber1, 1)
    vnumber2 = Left(vnumber2, 1)
    
    Dim result As String
    
    result = "cit_" & vcity & "_" & vnumber1 & "_" & vnumber2 & "_" & vregion
    result = LCase(result)
    
    Range("A" & x).Value = result

Next x

End Sub

Wbudowana funkcja Len określi mi ilość znaków w danym napisie. 

Dim lenghtcity
lenghtcity = Len(vcity)

If lenghtcity > 4 Then
    vcity = Left(vcity, 4)
End If

Korzystając z funkcji Left jestem w stanie wyciągnąć z danego napisu pierwsze 4 znaki.

vnumber1 = Right(vnumber1, 1)
vnumber2 = Left(vnumber2, 1)

Istnieje też podobna funkcja Right, która wyciągnie mi znaki od końca mojego napisu lub numeru.

result = "cit_" & vcity & "_" & vnumber1 & "_" & vnumber2 & "_" & vregion
result = LCase(result)
Range("A" & x).Value = result

Na koniec pozostało nam te napisy złączyć i umieścić ich zawartość do kolumny "A".

To był fragment naszego zadania. Teraz przechodzimy do generowania arkuszy przy użyciu VBA.

Cały ten wcześniejszy kod możemy przerobić na funkcje, która nam zwróci tablice wygenerowanych napisów. Ta tablica będzie nam potrzebna do generacji szablonów.

Function DajTabliceKodow() As String()

Dim arr(7) As String
Dim index As Integer
index = 0

For x = 2 To 9
    
    Dim cellcity, cellnumber1, cellnumeber2, cellregion As String
    
    cellcity = "B" & x
    cellnumber1 = "C" & x
    cellnumeber2 = "D" & x
    cellregion = "E" & x
    
    Dim vcity, vnumber1, vnumber2, vregion As String
    
    vcity = Range(cellcity).Value
    vnumber1 = Range(cellnumber1).Value
    vnumber2 = Range(cellnumeber2).Value
    vregion = Range(cellregion).Value
       
    Dim lenghtcity
    lenghtcity = Len(vcity)
    
    If lenghtcity > 4 Then
        vcity = Left(vcity, 4)
    End If
    
    vnumber1 = Right(vnumber1, 1)
    vnumber2 = Left(vnumber2, 1)
    
    Dim result As String
    
    result = "cit_" & vcity & "_" & vnumber1 & "_" & vnumber2 & "_" & vregion
    result = LCase(result)
    
    arr(index) = result
    index = index + 1
    
Next x

DajTabliceKodow = arr

End Function

Do działania będziemy też potrzebować innych pomocniczych funkcji. Potrzebujemy funkcji, która zwróci nam wielkość danej tablicy

Public Function GetArrLength(a As Variant) As Integer
   If IsEmpty(a) Then
      GetArrLength = 0
   Else
      GetArrLength = UBound(a) - LBound(a) + 1
   End If
End Function

Przyda nam się też funkcja, która sprawdzi dla bezpieczeństwa czy nie istnieje już taki arkusz o takiej nazwie.

Function Sheet_Exists(WorkSheet_Name As String) As Boolean
Dim Work_sheet As Worksheet
 
Sheet_Exists = False
 
For Each Work_sheet In ThisWorkbook.Worksheets
 
    If Work_sheet.Name = WorkSheet_Name Then
        Sheet_Exists = True
    End If
 
Next
 
End Function

Jak można dodać arkusz w VBA? Wystarczy taki fragment kodu

Sheets.Add.Name = "NowyArkusz"

Jeśli chcesz dodać arkusz przed lub po jakiś arkuszu to kod trochę ulega zmianie.

Sheets.Add After:=Sheets("Arkusz1") 'Dodaj po Arkuszu1'
Sheets.Add(After:=Sheets("Arkusz1")).Name = "NowyArkusz" 'Dodaj po Arkuszu1 i zmień nazwe'

Sheets.Add(Before:=Sheets(1)).Name = "FirstSheet 'Dodaj na początku'

Nas jednak interesuje kopiowanie i umieszczanie każdego kolejno takiego szablonu na końcu.

Kod generujący wygląda tak

Sub UtworzArkusze()

Dim arr() As String
arr = DajTabliceKodow()

Dim sizeArray
sizeArray = GetArrLength(arr)

For y = 0 To sizeArray - 1

    Dim Sheet_Name As String
    
    Sheet_Name = arr(y)
    
    If (Sheet_Exists(Sheet_Name) = False) Then
    
        Sheets("ArkuszDoKopiowania").Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = Sheet_Name
        
    End If
Next y

End Sub

Jak widzisz dosyć łatwo jest utworzyć dynamicznie arkusze w VBA w Excelu.

Najbardziej interesuje cię zapewne ten fragment kodu. Metoda Copy utworzy kopię, a funkcja After ustawi nowo wygenerowany tak szablon na samym końcu.

Sheets("ArkuszDoKopiowania").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Sheet_Name

Gdy ten szablon się generuje to jest on w tym momencie aktywnym szablonem.  To daje nam możliwość odwołania się do niego i wtedy mam szanse zmienić jego nazwę.

To wszystko. Pamiętaj tylko o tym, aby aktywować/zaznaczyć odpowiedni arkusz, gdy uruchamiasz takie makro w VBA.