Archiwa tagu: Zakres bez nagłówka

Transpozycja części kolumn zakresu

Opublikowany przez
1

Dzisiaj spory kawałek kodu. Aplikacja „Transpozycja części kolumn” naprawia błąd projektu tabelki, w której występuje grupa kolumn (np kolejne miesiące są nagłówkami kolumn). Zamienia ona te kolumny na dwie: Nagłówek i Wartość, odpowiednio wydłużając tabelkę przyległymi danymi. Taka tabelka dużo lepiej nadaje się do analizy…
Udanej transpozycji życzę 🙂

Option Explicit
 
Sub TranspozycjaCzesciKolumn()
 
    ' funkcjonalność:
    ' ===============
    ' Aplikacja zamienia zaznaczony zakres
    ' grupy kolumn w dwie kolumny - nagłówek i wartość,
    ' powtarzając dane przyległe
    ' dla każdego dokładanego wiersza.
    ' Wynik umieści w nowym arkuszu.
 
    ' założenia:
    ' ==========
    ' - zakres do transpozycji to końcowe kolumny tabeli
    '   wraz z nagłówkami (ma nagłówki!)
    ' - nazwy nagłówków kolumn docelowych
    '   to stałe NAGLOWEK i WARTOSC
    '   (można sobie zmienić ich wartość)
    ' - nie sprawdzamy, czy wynik zmieści się w arkuszu
 
    Const WERSJA As String = "Transpozycja części kolumn v.1.0 (Akademia-VBA.pl)"
    Const NAGLOWEK As String = "NAGŁÓWEK"
    Const WARTOSC As String = "WARTOŚĆ"
 
    Dim NazwaKolumny As String
    Dim ZakresTranspozycji As Range
    Dim ZakresPowtarzany As Range
    Dim ZakresCalkowity As Range
    Dim LW As Long, LK As Long, RoznicaK As Long, K As Long
    Dim LW_Wart As Long, W As Long
    Dim Ark As Worksheet
    Dim ZakresPowtarzany_BN As Range
    Dim KomNaglowkowa As Range, ZakresWartosci As Range
    Dim PoczNaglowki As Range, PoczWartosci As Range
 
    On Error GoTo Obsluga
 
    Set ZakresTranspozycji = Application.InputBox( _
        Prompt:="Podaj zakres kolumn do transpozycji (z nagłówkami)", _
        Title:=WERSJA, _
        Type:=8)
    LW = ZakresTranspozycji.Rows.Count
    LK = ZakresTranspozycji.Columns.Count
    Set ZakresCalkowity = ZakresTranspozycji.CurrentRegion
    RoznicaK = ZakresCalkowity.Columns.Count - LK
    Set ZakresPowtarzany = _
        ZakresCalkowity.Resize(LW, RoznicaK)
    ZakresPowtarzany.Interior.ColorIndex = 34
    ZakresTranspozycji.Interior.ColorIndex = 36
    Set Ark = Sheets.Add()
    Ark.Name = "Transpozycja" & StempelCzasowy
    ZakresPowtarzany.Copy Ark.Range("A1")
    Set ZakresPowtarzany_BN = _
        ZakresBezNaglowka(Ark.Range("A1").CurrentRegion)
    ZakresPowtarzany_BN.Interior.ColorIndex = 37
    LW_Wart = ZakresPowtarzany_BN.Rows.Count
    Set PoczNaglowki = Ark.Cells(1, RoznicaK + 1)
    PoczNaglowki = NAGLOWEK
    Set PoczWartosci = Ark.Cells(1, RoznicaK + 2)
    PoczWartosci = WARTOSC
    For K = 1 To LK
        Set KomNaglowkowa = ZakresTranspozycji.Cells(1, K)
        Set ZakresWartosci = _
            ZakresBezNaglowka(ZakresTranspozycji.Columns(K))
        For W = 1 To LW_Wart
            KomNaglowkowa.Copy PoczNaglowki.Offset(W, 0)
        Next
        Set PoczNaglowki = PoczNaglowki.Offset(LW_Wart, 0)
        ZakresWartosci.Copy PoczWartosci.Offset(1, 0)
        Set PoczWartosci = PoczWartosci.Offset(LW_Wart, 0)
        If K = LK Then Exit For
        ZakresPowtarzany_BN.Copy _
            ZakresPowtarzany_BN.Offset(LW_Wart * K, 0)
    Next
 
    Exit Sub
Obsluga:
    If Err = 424 Then
        MsgBox "Należy zaznaczyć zakres kolumn do transpozycji", _
            vbExclamation, WERSJA
    Else
        MsgBox Err.Description, vbCritical, WERSJA
    End If
End Sub
 
Function ZakresBezNaglowka(Zakres As Range) As Excel.Range
 
    Dim LW As Long, LK As Long
 
    LW = Zakres.Rows.Count
    LK = Zakres.Columns.Count
    Set ZakresBezNaglowka = _
        Range(Zakres.Cells(2, 1), Zakres.Cells(LW, LK))
 
End Function
 
Function StempelCzasowy() As String
    StempelCzasowy = Format(Now(), "_yyyymmdd_hhmmss")
End Function