35100_excel_sloupce.png
Zdroj na prvním, výsledek na druhém listu.
Sub Spojovacka()
Dim wshZdroj As Worksheet
Dim wshCil As Worksheet
Dim rngOblast As Range
Dim rngTempBunka1 As Range
Dim rngTemp As Range
Dim intTemp As Integer
Dim intRadek As Integer
Dim intPocetSloupcu As Integer
'zamezeni prekreslovani a prepoctu
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'prirazeni zdrojoveho listu do promenne
Set wshZdroj = Worksheets(1)
'prirazeni ciloveho listu do promenne
Set wshCil = Worksheets(2)
'vycisteni ciloveho listu
wshCil.UsedRange.Clear
'prirazeni kopirovane oblasti do promenne
Set rngOblast = wshZdroj.Cells(1).CurrentRegion
With wshCil
'kopie na druhy list
rngOblast.Copy .Cells(1)
'pocet sloupcu
intPocetSloupcu = .Range(.Cells(1), _
.Cells(1).End(xlToRight)).Cells.Count
'prvni volny radek prvni podoblasti s parovymi hodnotami
intRadek = .Range(.Cells(1), .Cells(1).End(xlDown)).Cells.Count + 1
'zpracovani podoblasti s parovymi hodnotami
For i = 2 To intPocetSloupcu \ 2
'prvni bunka podoblasti
Set rngTempBunka1 = .Cells(1, 2 * i - 1)
'pocet paru v podoblasti
intTemp = .Range(rngTempBunka1, rngTempBunka1.End(xlDown)).Cells.Count - 1
'prevzeti podoblasti
Set rngTemp = rngTempBunka1.Offset(1, 0).Resize(intTemp, 2)
'presun podoblasti
rngTemp.Cut Cells(intRadek, 1)
'nasledujici volny radek
intRadek = intRadek + intTemp
Next i
'vycisteni radku hlavicek
.Range(.Cells(1, 3), .Cells(1, 3).End(xlToRight)).Clear
End With
'povoleni prepoctu a prekreslovani
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Subcitovat
Sub Spojovacka()
Dim wshZdroj As Worksheet
Dim wshCil As Worksheet
Dim rngOblast As Range
Dim rngTempBunka1 As Range
Dim rngTemp As Range
Dim intTemp As Integer
Dim intRadek As Integer
Dim intPocetSloupcu As Integer
'zamezeni prekreslovani a prepoctu
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'prirazeni zdrojoveho listu do promenne
Set wshZdroj = Worksheets(1)
'prirazeni ciloveho listu do promenne
Set wshCil = Worksheets(2)
'vycisteni ciloveho listu
wshCil.UsedRange.Clear
'prirazeni kopirovane oblasti do promenne
Set rngOblast = wshZdroj.Cells(1).CurrentRegion
With wshCil
'kopie na druhy list
rngOblast.Copy .Cells(1)
'pocet sloupcu
intPocetSloupcu = .Range(.Cells(1), _
.Cells(1).End(xlToRight)).Cells.Count
'prvni volny radek prvni podoblasti s parovymi hodnotami
intRadek = .Range(.Cells(1), .Cells(1).End(xlDown)).Cells.Count + 1
'zpracovani podoblasti s parovymi hodnotami
For i = 2 To intPocetSloupcu \ 2
'prvni bunka podoblasti
Set rngTempBunka1 = .Cells(1, 2 * i - 1)
'pocet paru v podoblasti
intTemp = .Range(rngTempBunka1, rngTempBunka1.End(xlDown)).Cells.Count - 1
'prevzeti podoblasti
Set rngTemp = rngTempBunka1.Offset(1, 0).Resize(intTemp, 2)
'presun podoblasti
rngTemp.Cut Cells(intRadek, 1)
'nasledujici volny radek
intRadek = intRadek + intTemp
Next i
'vycisteni radku hlavicek
.Range(.Cells(1, 3), .Cells(1, 3).End(xlToRight)).Clear
End With
'povoleni prepoctu a prekreslovani
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Subcitovat
35103_spoj-stlpce.zip
35133_jmenovecpq.xlsx
RSS nejnovější články