Concatenar y copiar de varios archivos a otro archivo en especifico para Dante amor
Buenas días dante amor una pregunta sera que aya alguna forma de concatenar las observaciones y queden en los comentarios te agradecería esta pequeña modificación
Seria de los comentarios del archivo que se llama BD logística y facturiacion a comentarios administacion y finanzas que se llama el archivo junta operativa pedido a pedido muchas gracias
Respuesta de Dante Amor
1
Te envié el archivo con los cambios a la macro. Esta es la macro completa
Sub copiar()
'
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Semana 37")
'
ruta = l1.Path
Set l2 = Workbooks.Open(ruta & "\" & "BD Ventas")
Set h2 = l2.Sheets("VENTAS")
'
u1 = h1.UsedRange.Rows(h1.UsedRange.Rows.Count).Row
If u1 < 3 Then u1 = 3
h1.Range("A3:O" & u1).Clear
'
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
h2.Range("A3:O" & u2).Copy h1.Range("A3")
'
l2.Close False
'
'Abrir "BD LOGISTICA Y FACTURACION"
Set l2 = Workbooks.Open(ruta & "\" & "BD LOGISTICA Y FACTURACION")
Set h2 = l2.Sheets("ADMON Y LOGISTICA")
For i = 3 To h2.Range("A" & Rows.Count).End(xlUp).Row
Set r = h1.Columns("A")
Set b = r.Find(h2.Cells(i, "A"), lookat:=xlWhole)
If Not b Is Nothing Then
ncell = b.Address
Do
prim = h1.Cells(b.Row, "B")
seg = h2.Cells(i, "B")
If Val(h1.Cells(b.Row, "B")) = Val(h2.Cells(i, "B")) Then
h1.Cells(b.Row, "AF") = h1.Cells(b.Row, "AF") & h2.Cells(i, "K") & " / " & h2.Cells(i, "U") & " / "
Exit Do
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
l2.Close
'Abrir "BD Compras y Logística"
Set l2 = Workbooks.Open(ruta & "\" & "BD Compras y Logística")
Set h2 = l2.Sheets("COMPRAS Y LOGISTICA")
For i = 3 To h2.Range("A" & Rows.Count).End(xlUp).Row
Set r = h1.Columns("A")
Set b = r.Find(h2.Cells(i, "A"), lookat:=xlWhole)
If Not b Is Nothing Then
ncell = b.Address
Do
prim = h1.Cells(b.Row, "B")
seg = h2.Cells(i, "B")
If Val(h1.Cells(b.Row, "B")) = Val(h2.Cells(i, "B")) Then
h1.Cells(b.Row, "AI") = h2.Cells(i, "U")
Exit Do
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
l2.Close
'Abrir "BD Control de Calidad"
Set l2 = Workbooks.Open(ruta & "\" & "BD Control de Calidad")
Set h2 = l2.Sheets("BD")
For i = 3 To h2.Range("A" & Rows.Count).End(xlUp).Row
Set r = h1.Columns("A")
Set b = r.Find(h2.Cells(i, "A"), lookat:=xlWhole)
If Not b Is Nothing Then
ncell = b.Address
Do
prim = h1.Cells(b.Row, "B")
seg = h2.Cells(i, "B")
If Val(h1.Cells(b.Row, "B")) = Val(h2.Cells(i, "B")) Then
h1.Cells(b.Row, "Z") = h2.Cells(i, "AW")
Exit Do
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
l2.Close
'Abrir "PRODUCCIÓN"
Set l2 = Workbooks.Open(ruta & "\" & "DB Produccion", ReadOnly:=True)
Set h2 = l2.Sheets("SEPTIEMBRE")
For i = 3 To h2.Range("C" & Rows.Count).End(xlUp).Row
Set r = h1.Columns("A")
Set b = r.Find(h2.Cells(i, "A"), lookat:=xlWhole)
If Not b Is Nothing Then
ncell = b.Address
Do
If Val(h1.Cells(b.Row, "B")) = Val(h2.Cells(i, "B")) Then
h1.Cells(b.Row, "W") = h2.Cells(i, "P")
Exit Do
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
l2.Close False
MsgBox "Se copió la información de Ventas", vbInformation
End Sub
