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 |
Fajny kod. Proponuję jeszcze zoptymalizować wklejanie nazwy nagłówka nie w pętli, a przypisując komórkę nagłówka tabeli źródłowej do odpowiedniego zakresu
Dim PodkolumnaNaglowka As Range
(…)
Set PodkolumnaNaglowka = ZakresPowtarzany_BN.Resize(, 1).Offset(, RoznicaK)
(…)
'W dużej pętli:
PodkolumnaNaglowka = KomNaglowkowa
(…)
Set PodkolumnaNaglowka = PodkolumnaNaglowka.Offset(LW_Wart, 0)