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 |
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