Saltar al contenido

tabular informacion

publicado

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

Featured Replies

publicado

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

publicado
  • Autor

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

 

image.thumb.png.25b807bf8be5087c0907c63a7f343dab.png

 

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

bendiciones.

 

publicado
  • Autor

Dios siga bendiciendo su vida y su conocimiento. 

bendiciones.

 

muchas gracias. 

publicado
  • Autor

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: image.thumb.png.bdad80632d6644e2d80053160195491e.png

image.thumb.png.1db4439a51b206333030d04d95129366.png

les agradezco me puedan aconsejar para organizar la información

lotes_produccion (19).xls

publicado

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

publicado
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

publicado
  • Autor

buenos dias.

 

Dios bendiga su vida.

 

infinitas gracias por la ayuda.!

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.