Excel Transpondo Toda enésima linha a cada enésima coluna

Question

Estou tentando descobrir isso há algum tempo e todas as soluções que tentei não foram muito bem-sucedidas para o que estou tentando.

Basicamente, o que estou tentando fazer é pegar todas as outras linhas de uma planilha que pode ter de 3 a 80 colunas e transpô-las para novas colunas ao lado de onde elas estavam antes, excluindo as linhas agora vazias.

Eu quero fazer isso:

paraisso:

Consegui algumas coisas funcionando, como copiar todas as outras linhas e inserir colunas, mas a parte que parece estar me evadindo é fazer com que as colunas coloridas também sejam copiadas. E como mencionei, escalá-lo a partir de qualquer tamanho de planilha também parece ser a parte que mais me pega.

Alguma boa ideia?

    

Answer 1

A maneira mais fácil de obter as cores (e outras características da fonte) é fazer um processo Copy . Se isso for muito lento, podemos investigar outras opções.

Eu sugeriria

• Copie os dados originais para uma nova planilha (para preservar seus dados originais)
• Determine a última coluna fixa - na sua amostra, é a coluna denominada Diluição:
• Após a última coluna fixa +1, insira uma nova coluna todas as outras colunas na última coluna real
• copie as informações na segunda linha de cada conjunto de dados e à direita uma célula (na coluna agora vazia).
• excluir todas as linhas que estão em branco na coluna A

Option Explicit
Sub Interleave2()
    Dim wsSrc As Worksheet, wsRes As Worksheet
    Dim rSrc As Range, rRes As Range
    Dim LastRow As Long, LastCol As Long
    Dim LastFixedColumn As Long
    Dim I As Long, J As Long, K As Long, L As Long

Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")

With wsSrc
    LastRow = .Cells.Find(what:="*", after:=.Cells(1, 1), _
             LookIn:=xlFormulas, searchorder:=xlByRows, _
             searchdirection:=xlPrevious).Row

    LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
             LookIn:=xlFormulas, searchorder:=xlByColumns, _
             searchdirection:=xlPrevious).Column

    Set rSrc = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With

LastFixedColumn = rSrc.Find(what:="Dilution:", after:=rSrc.Cells(1)).Column

Application.ScreenUpdating = False

wsRes.Cells.Clear
rSrc.Copy wsRes.Cells(1, 1)

For I = LastCol To LastFixedColumn + 2 Step -1
    Cells(1, I).EntireColumn.Insert shift:=xlToRight
Next I

With wsRes
    LastRow = .Cells.Find(what:="*", after:=.Cells(1, 1), _
             LookIn:=xlFormulas, searchorder:=xlByRows, _
             searchdirection:=xlPrevious).Row

    LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
             LookIn:=xlFormulas, searchorder:=xlByColumns, _
             searchdirection:=xlPrevious).Column

    Set rRes = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With

For I = 3 To rRes.Rows.Count Step 2
    For J = LastFixedColumn + 1 To rRes.Columns.Count Step 2
        rRes(I, J).Copy rRes(I - 1, J + 1)
    Next J
Next I

With rRes
    .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    With .EntireColumn
        .ColumnWidth = 255
        .AutoFit
    End With
    .EntireRow.AutoFit
End With

Application.ScreenUpdating = True
End Sub