Buscar fecha, Copiar datos en una hoja nueva e imprimir

[MauriciodeAbreu]

Buenas dias amigos.

Vengo con un problemita que de seguro es simple, pero no doy con la solucion.

Necesito que se busque en una columna la fecha del dia en curso, y al encontrar la fecha, copie los valores a la izquierda (es decir, los Seriales), en una hoja nueva bajo el nombre de "Seriales y la fecha del dia en curso", pero, al copiar los datos, debe dividirlo cada 44 filas (ya que cebe tener encabezado) y brincar a la fila inicial de la siguiente columna, y asi sucesivamente e imprimir esa hoja nueva.

Dejo un archivo de ejemplo.

Agradecido de antemano por vuestra ayuda.

Busqueda creacion e impresion.rar

[MauriciodeAbreu]

Buenas noches estimados.

He estado un poco liado, por lo que no he podido postear.

He logrado hacer lo siguiente a partir de un codigo que encontre, pero se me complica al querer agregar los seriales de la otra tabla.

    Dim Fecha, DateCells As Date
    Dim X, Y, Z, W, uf, Filas As Integer
    Dim Skip, Adding As Boolean
    Dim rng As Range
    Dim InputRng As Range
    Dim OutRng As Range
    Dim xRow As Integer
    Dim xCol As Integer
    Dim xArr As Variant
    Dim iRow, iCol As Integer

Sub ImprimirSeriales()
    ImprimirSerialesTabla Sheets("Operativas")': Cells.Select: Selection.Columns.AutoFit: Adding = True ': ActiveSheet.Move _
    After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
    ImprimirSerialesTabla Sheets("Inoperativas"): Cells.Select: Selection.Columns.AutoFit
End Sub

Private Sub ImprimirSerialesTabla(Tabla As Worksheet)
    Sheets("Operativas").Activate
    Fecha = Format(Date, "dd-mm-yyyy")
    With Tabla
        uf = .Range("B" & Rows.Count).End(xlUp).Row
        For X = 2 To uf
            If .Range("C" & X) = vbNullString Then MsgBox "Usted llego al final de la tabla." & vbNewLine & "Y no hay registrso con la fecha de hoy": Exit Sub
            DateCells = Format(.Range("C" & X), "dd/mm/yyyy")
            If Fecha = DateCells Then
                If Adding = True Then AgregarInoperativos: Exit Sub
                Set InputRng = ActiveSheet.Range(Cells(X, 2), Cells(uf, 2)) 'Sheets("Operativas")
                xRow = 44 'Cantidad de filas por columna
                Worksheets.Add.Name = "Seriales " & Fecha 'Crear hoja nueva con nombre definido y la fecha del dia en curso
                Set OutRng = Sheets("Seriales " & Fecha).Range("A2")
                Set InputRng = InputRng.Columns(1)
                xCol = InputRng.Cells.Count / xRow
                ReDim xArr(1 To xRow, 1 To xCol + 1)
                Z = InputRng.Cells.Count - 1
                For i = 0 To InputRng.Cells.Count - 1
'                    Z = InputRng.Cells.Count - 1
                    xValue = InputRng.Cells(i + 1)
                    iRow = i Mod xRow
                    W = iRow
                    iCol = VBA.Int(i / xRow)
                    Sheets("Seriales " & Fecha).Range(Cells(1, 1), Cells(1, iCol + 1)) = "Seriales"
                    xArr(iRow + 1, iCol + 1) = xValue
                Next
                OutRng.Resize(UBound(xArr, 1), UBound(xArr, 2)).Value = xArr
                Exit Sub
            End If
        Next
    End With
End Sub

Por lo que recurro a ustedes, con la esperanza de que me den alguna luz de como completar el proceso.

Agradecido como siempre por las ideas, o ayuda que me puedan brindar.