tabular informacion

[carfa2286]

buenas,

 

soy nuevo en este foro. queria pedirles el favor de darme unas pautas para poder crear una macro para organizar la informacion del archivo. consta de dos hojas.

 

la primera hoja esta la informacion que se exporta de sistema y en la otra esta el ejemplo de como querria organizarla. como son demasiados datos manual es muy engorroso.

 

agradezco me puedan dar una explicacion de como hacer

lotes_produccion (16).xls

[JSDJSD]

Si nadie te da solución antes mañana lo intento

[JSDJSD]

Prueba y comenta

[JSDJSD]

El botón puedes eliminarlo y ejecutar la macro como tu veas.

Sub ExtraerDatos()
    Sheets("ejemplo").Cells.Clear
    Sheets("Sheet1").Rows.Copy Sheets("ejemplo").Rows

    Set hojaOrigen = ThisWorkbook.Sheets("Sheet1")
    Set hojaDestino = ThisWorkbook.Sheets("ejemplo")

    ultimaFila = hojaOrigen.Cells(hojaOrigen.Rows.Count, "A").End(xlUp).Row
    vCliente = ""
    vOrden = ""
    vProyecto = ""
    vComposicion = ""

    For i = 1 To ultimaFila
        If Trim(Left(hojaOrigen.Cells(i, 1).Value, 11)) = "Cliente :" Then
            vCliente = Mid(hojaOrigen.Cells(i, 1).Value, 12)
            
            Do While i <= ultimaFila And InStr(1, hojaOrigen.Cells(i, 1).Value, "Orden :") = 0
                vCliente = vCliente & " " & hojaOrigen.Cells(i, 1).Value
                i = i + 1
            Loop
            
            If i <= ultimaFila Then
                vCliente = Trim(Left(vCliente, InStr(1, vCliente, "Orden :") - 1))
                hojaDestino.Range("P" & i + 2) = "Cliente"
                hojaDestino.Range("P" & i + 3) = vCliente
                hojaDestino.Columns("P").AutoFit
                
                vOrden = Mid(hojaOrigen.Cells(i, 1).Value, InStr(1, hojaOrigen.Cells(i, 1).Value, "Orden :") + Len("Orden :"))
                
                Do While i <= ultimaFila And InStr(1, hojaOrigen.Cells(i, 1).Value, "Proyecto :") = 0
                    vOrden = vOrden & " " & hojaOrigen.Cells(i, 1).Value
                    i = i + 1
                Loop
                
                If i <= ultimaFila Then
                    vOrden = Trim(Left(vOrden, InStr(1, vOrden, "Proyecto :") - 1))
                    hojaDestino.Range("O" & i + 2) = "Orden"
                    hojaDestino.Range("O" & i + 3) = vOrden
                    hojaDestino.Columns("O").AutoFit
                    
                    vProyecto = Mid(hojaOrigen.Cells(i, 1).Value, InStr(1, hojaOrigen.Cells(i, 1).Value, "Proyecto :") + Len("Proyecto :"))
                    
                    hojaDestino.Range(" Q" & i + 2) = "Proyecto"
                    hojaDestino.Range("Q" & i + 3) = vProyecto
                    hojaDestino.Columns("Q").AutoFit
                    
                    Do While i <= ultimaFila And InStr(1, hojaOrigen.Cells(i, 1).Value, "Composicion :") = 0
                        i = i + 1
                    Loop
                    
                    If i <= ultimaFila Then
                        vComposicion = Mid(hojaOrigen.Cells(i, 1).Value, InStr(1, hojaOrigen.Cells(i, 1).Value, "Composicion :") + Len("Composicion :"))
                        hojaDestino.Range("R" & i + 1) = "Composicion"
                        hojaDestino.Range("R" & i + 2) = vComposicion
                        hojaDestino.Columns("R").AutoFit
                    End If
                End If
            End If
        End If
    Next i
    
    EliminarFilasClienteComposicion
End Sub

Sub EliminarFilasClienteComposicion()
    Dim hoja As Worksheet
    Dim ultimaFila As Long
    Dim i As Long

    Set hoja = ThisWorkbook.Sheets("ejemplo")
    ultimaFila = hoja.Cells(hoja.Rows.Count, "A").End(xlUp).Row

    For i = ultimaFila To 1 Step -1
        If InStr(1, UCase(hoja.Cells(i, 1).Value), "CLIENTE") > 0 Or InStr(1, UCase(hoja.Cells(i, 1).Value), "COMPOSICION") > 0 Then
            hoja.Rows(i).Delete
        End If
    Next i
End Sub

 

lotes_produccion (16).xls

[carfa2286]

buenos dias. le agradezco muchisimo. veo que no llena todos los rangos.

 

 

la idea es que repita los registros de la orden, cliente, proyecto y composición.

bendiciones.

 

[JSDJSD]

Pon ejemplo de cómo quedaria

[JSDJSD]

A ver si es esto lo que necesitas

[JSDJSD]

El archivo

lotes_produccion (16).xls

[carfa2286]

Dios siga bendiciendo su vida y su conocimiento. 

bendiciones.

 

muchas gracias. 

[carfa2286]

buenas,

 

tengo el siguiente archivo con la misma información pero cada vez que lo exporto la información esta me lo trae con combinaciones de celdas. se podría ajustar el código para organizar la información y suprimir los títulos repetidos y solo dejar uno solo: 

les agradezco me puedan aconsejar para organizar la información

lotes_produccion (19).xls

[JSDJSD]

Deja un ejemplo de como debe quedar y  abre un tema nuevo

[carfa2286]

buenas,

 

adjunto ejemplo.

 

agradezco la ayuda.

lotes_produccion (19).xls

[JSDJSD]

Prueba y comenta

[JSDJSD]

Sub Limpiar(): Application.ScreenUpdating = False
    With Hoja1
        .ClearArrows
        .Range("A1", "S" & .Range("S" & Rows.Count).End(xlUp).Row).Copy Destination:=Hoja7.Range("A1")
    End With

    With Hoja7.Range("A:S")
        uf = .Range("S" & Rows.Count).End(xlUp).Row
        .UnMerge
        .WrapText = False
        .Columns("A:S").AutoFit
        .Range("C3", "R" & uf).Select
        Selection.Cut Destination:=.Range("C2", "R" & uf - 1)

        For x = uf To 2 Step -1
            If .Cells(x, 2) = "" Or .Cells(x, 3) = "" Then
            .Cells(x, 2).EntireRow.Delete
            End If
        Next x

        For y = 2 To .Range("S" & Rows.Count).End(xlUp).Row
        Cliente = .Range("A" & y): Orden = .Range("B" & y): Campo = .Range("S" & y)
            If .Cells(y + 1, 1) = "Nom_Cliente" Then
               .Cells(y + 1, 1) = Cliente: .Cells(y + 1, 2) = Orden: .Cells(y + 1, 19) = Campo
               .Cells(y + 1, 1).WrapText = False: .Cells(y + 1, 2).WrapText = False: .Cells(y + 1, 19).WrapText = False
               .Cells(y + 1, 1).Font.Bold = True: .Cells(y + 1, 2).Font.Bold = True: .Cells(y + 1, 19).Font.Bold = True
            End If
        Next y
    End With
End Sub

 

lotes_produccion (19) (1).xlsm

[carfa2286]

buenos dias.

 

Dios bendiga su vida.

 

infinitas gracias por la ayuda.!