Macro para Extraer información de otro Archivo II

A los miembros de este foro, hace mucho tiempo me ayudaron con esta macro que consiste en como extraer información de un archivo cerrado y la cual me sigue ayudando mucho, ahora quiero que me brinde su apoyo bajo la misma primicia que extraiga el siguiente valor que se encuentra resaltado de color amarillo, y deben ser agregados en el archivo PLANILLA000.xlsm en la Columna L filas 4 - 20 - 36 - 52 - 68 - 84 - 100 - 116 - 132 - 148

getClosedWbData.bas

Sub CODIGOS()
' procedimiento para obtener datos de un libro cerrado segun condiciones ' _
  R&D: Héctor Miguel Orozco Díaz | mayo de 2016 '
  Dim ruta As String, archivo As String, hoja As String, pas As String, _
         conexion As Object, registros As Object, celda As Range
  ruta = ThisWorkbook.Path & "\" ' <= carpeta donde se encuentra el... '
  'archivo = "sort.xlsm" ' archivo del que se rescatan los codigos en ... '
  archivo = "sort estiba.xlsm" ' archivo del que se rescatan los codigos en ... '
  hoja = "ingreso" ' la hoja que los contiene '
  pass = "A" ' <= la contraseña para (des/re)proteger la hoja '
  ActiveSheet.Unprotect pass
  Set conexion = CreateObject("adodb.connection")
  Set registros = CreateObject("adodb.recordset")
  conexion.Open "provider=microsoft.ace.oledb.12.0;data source=" & ruta & archivo & _
                   ";extended properties=""excel 12.0 xml;imex=1;hdr=yes"";"
  For Each celda In Range([a1], Cells(Rows.Count, 1).End(xlUp)).SpecialCells(2, 2)
    If celda = "COD" Then
      celda.Offset(, 10) = ""
      registros.Open "select grupo from [" & hoja & "$] where cod = """ & celda.Offset(, 1) & """", conexion, 1, 1
      If registros.RecordCount > 0 Then _
        celda.Offset(, 10) = Join(Application.Transpose(Application.Transpose(registros.GetRows)), "; ")
      registros.Close
    End If: Next: ActiveSheet.Protect pass: Set registros = Nothing: conexion.Close: Set conexion = Nothing: MsgBox ("Extracción Terminado"), , "AVISO": End Sub

Añade tu respuesta

Haz clic para o