Sloučení párových sloupců do jednoho

Sub SlouceniParovychSloupcu()

    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("List1")
   
    'prirazeni ciloveho listu do promenne
    Set wshCil = Worksheets("List2")
   
    '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 Sub