Este fórum está sendo desativado

[Olvavila]

Boa Noite!

Tenho dados distribuídos em 3 colunas que vão de A1 até C211 e necessito imprimir estes dados em uma única folha de papel.
Uso o seguinte código em VBA

Código: Selecionar todos

Option Explicit
 
 
Sub Osmario()
    Dim s1 As Worksheet, s2 As Worksheet
    Set s1 = Sheets("Conferentes")
    Set s2 = Sheets("Lista")
    Dim lr As Long, i As Long, j As Long
    Dim k As Long, lc As Long
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row
    With s1
        i = lr / 60
        k = 2
        For j = 1 To i - 1
            lc = s2.Cells(1, Columns.Count).End(xlToLeft).Column
            .Range("A1:C1").Copy s2.Cells(1, lc + 2)
            .Range("A" & k & ":C" & k + 59).Copy s2.Cells(2, lc + 2)
            k = k + 59
        Next j
    End With
     
     
End Sub

Este código deveria partir as três colunas em quatro porções e, desta forma, acomodá-las em uma única folha mas isto nem sempre acontece.
Primeiramente, porque as colunas originais sofrem alterações para mais ou para menos em número de linhas, dependendo do número de funcionários que pode aumentar ou diminuir. Segundo porque, ao executar o código, o Excel repete o funcionário que finaliza um bloco no começo do outro.
Segue planilha em anexo.

Obrigado por qualquer ajuda
Osmário Ávila.

[alexandrevba]

Boa tarde!!

Faça um teste com essa rotina abaixo, caso lhe interesse adapte-a, do contrário aguarde o pessoal lhe enviar uma resposta mais precisa.

Código: Selecionar todos

Sub AleVBA_3189()
'Fonte: http://www.excelfox.com/forum/showthread.php/274-Split-Range-into-Multiple-Columns-VBA
'Autor: Rick Rothstein
'Editado por: AlexandreVBA
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Dim X As Long, R As Long, C As Long, Cols As Long, rngSource As Range, wksResult As Worksheet
Set sht = Worksheets("CONFERENTES")
Set StartCell = Range("A2")

Application.DisplayAlerts = False
On Error Resume Next
    ThisWorkbook.Sheets("Resultado").Delete
On Error GoTo 0
Application.DisplayAlerts = True

  Worksheets("CONFERENTES").UsedRange
  LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  sht.Range("A2:C" & LastRow).Select
    Set rngSource = Selection
    If Not rngSource Is Nothing Then
        Cols = (ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row) / 60
        If Cols > 0 Then
            Application.ScreenUpdating = False
            R = Application.RoundUp(rngSource.Rows.Count / Cols, 0)
            Set wksResult = Worksheets.Add: wksResult.Name = "Resultado"
            For X = 0 To rngSource.Rows.Count Step R
                rngSource.Offset(X).Resize(R, rngSource.Columns.Count).Copy wksResult.Range("A2").Offset(, C)
                C = C + rngSource.Columns.Count
            Next
            Application.ScreenUpdating = True
        End If
    End If
    With Worksheets("Resultado").Activate
        [A1:C1].Value = Worksheets("CONFERENTES").Range("A1:C1").Value
        [D1:F1].Value = Worksheets("CONFERENTES").Range("A1:C1").Value
        [G1:I1].Value = Worksheets("CONFERENTES").Range("A1:C1").Value
        [J1:L1].Value = Worksheets("CONFERENTES").Range("A1:C1").Value
        [A1:L1].Font.ColorIndex = 2
        [A1:L1].Interior.ColorIndex = 1
        Range("D:D,H:H,L:L").Insert shift:=xlRight
        Columns().AutoFit
    End With
End Sub

Att