Extraer datos de dos libros y datos no continuos

En un anterior post modificaste mi archivo, pero quedo pendiente otras columnas de las cuales una es la columna color proviene del MOLIENDA DE CEMENTO Y DESPACHOS FÍSICOS hoja PERDIDA Y FINURA CEMENTO 2021 pero este dato es discontinuo ya que los datos anteriores era hasta la columna G y este dato de color esta en la columna J, además debo extraer datos SO3 y Cl también no continuos de otro libro que se llama MOLIENDA DE CEMENTO Y DESPACHO hoja CEMENTO.

Además sera posible enlazar la hoja MIX PUZOLANICO del primer libro o debo hacer otra macro aparte.

Te adjunto imágenes y los archivos.

Molienda de cemento y despachos físicos

https://drive.google.com/file/d/1gH4CLfot7dMVgrUlV7aUNcLiTRCKlzYW/view?usp=sharing 

MOLIENDA DE CEMENTO Y DESPACHO

https://drive.google.com/file/d/1U__Z81ANbN4zBQIEFoqu4Heg9L9uPGxt/view?usp=sharing 

CONSULTAS CALIDAD

https://drive.google.com/file/d/15ZVjjL8SYgxP42Sb-rY4o2pvCtfLOF6z/view?usp=sharing 

En espera de sus valiosos conocimientos.

1 respuesta

Respuesta
1

Listo.

Prueba con los 3 archivos abiertos.

Sub CEMENTO()
'Por Dante Amor
  '
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim wb2 As Workbook, wb3 As Workbook
  Dim i As Long, fila As Long
  Dim col As String, llave As String
  Dim m As Variant, a As Variant
  Dim dic As Object
  '
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  '
  Set sh1 = ThisWorkbook.Sheets("CEMENTO")
  sh1.Range("C5:J22, L5:S22, U5:AB22").ClearContents
  '
  'Set wb = Workbooks.Open("\\10.7.10.1\calidad\SEGUIMIENTO HORA-HORA\MOLIENDA DE CEMENTO Y DESPACHOS FISICOS.xlsx", ReadOnly:=True)
  Set wb2 = Workbooks("MOLIENDA DE CEMENTO Y DESPACHOS FISICOS")
  Set sh2 = wb2.Sheets("PERDIDA Y FINURA CEMENTO 2021")
  Set wb3 = Workbooks("MOLIENDA DE CEMENTO Y DESPACHO")
  Set sh3 = wb3.Sheets("CEMENTO")
  Set dic = CreateObject("Scripting.Dictionary")
  '
  'Carga en una matriz y en un índice los Datos del libro 3
  a = sh3.Range("A2", sh3.Range("Q" & sh3.Range("A" & Rows.Count).End(3).Row)).Value2
  For i = 1 To UBound(a, 1)
    If Not IsError(a(i, 1)) Then
      dic(a(i, 1) & "|" & Val(a(i, 2)) & "|" & Right(a(i, 3), 1)) = a(i, 13) & "|" & a(i, 16)
    End If
  Next
  'Datos del libro2
  For i = 7 To sh2.Range("A" & Rows.Count).End(3).Row
    If Not IsError(sh2.Range("A" & i)) Then
      If sh2.Range("A" & i).Value = sh1.Range("C2").Value Then
        col = IIf(Left(sh2.Range("C" & i).Value, 1) = "M", Choose(Val(Right(sh2.Range("C" & i).Value, 1)), "", "", "C", "L", "U"), "")
        If col <> "" Then
          fila = 5
          Do While sh1.Cells(fila, col).Value <> ""
            fila = fila + 1
          Loop
          m = sh2.Cells(i, "B").Value * 1
          sh1.Cells(fila, col) = IIf(m < 12 Or m = 24, m Mod 24 & ":00 AM", m Mod 12 & ":00 PM")
          sh1.Cells(fila, Columns(col).Column + 1).Resize(1, 4).Value = sh2.Range("D" & i).Resize(1, 4).Value
          sh1.Cells(fila, Columns(col).Column + 5).Value = sh2.Range("J" & i).Value
          '
          llave = sh1.Range("C2").Value & "|" & m & "|" & Right(sh2.Range("C" & i).Value, 1)
          If dic.exists(llave) Then
            sh1.Cells(fila, Columns(col).Column + 6).Resize(1, 2).Value = Split(dic(llave), "|")
          End If
        End If
      End If
    End If
  Next
  '
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  '
  If sh1.Range("C5, L5, U5") = "" Then
    MsgBox "No hay datos reportados para este día"
  End If
End Sub

Muy buenos días, Dante

Gracias por ayudarme a que mi informe sea más eficiente.

Te comento inicie la macro enviada con los dos libros abiertos y me genera el sigueimte error.

Saludos,

Mira le coloque la extensión a los archivos y corrió pero laza este error.

Este es el error

¿Y qué dice el mensaje de error?

Cambia

Choose

Por:

Worksheetfunction. Choose

Presente el siguiente error en la misma línea

Entonces cambia esta línea:

col = IIf(Left(sh2.Range("C" & i).Value, 1) = "M", Choose(Val(Right(sh2.Range("C" & i).Value, 1)), "", "", "C", "L", "U"), "")

Por estas:

        Select Case sh2.Range("C" & i).Value
          Case "M3": col = "C"
          Case "M4": col = "L"
          Case "M5": col = "U"
          Case Else: col = ""
        End Select

Ok listo.pero debo tener los libros abiertos?

Esos archivos son de laboratorio y no puedo mantenerlos abieros.

Como comenté, solamente para las pruebas abre los 3 libros.

Después de que hagas las pruebas. Ya puedes cambiar las instrucciones para abrir y cerrar los libros.

Va la macro para abrir y cerrar. Recuerda valorar la respuesta.

Sub CEMENTO()
'Por Dante Amor
  '
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim wb2 As Workbook, wb3 As Workbook
  Dim i As Long, fila As Long
  Dim col As String, llave As String
  Dim m As Variant, a As Variant
  Dim dic As Object
  '
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  '
  Set sh1 = ThisWorkbook.Sheets("CEMENTO")
  sh1.Range("C5:J22, L5:S22, U5:AB22").ClearContents
  '
  'Set wb2 = Workbooks.Open("\\10.7.10.1\calidad\SEGUIMIENTO HORA-HORA\MOLIENDA DE CEMENTO Y DESPACHOS FISICOS.xlsx", ReadOnly:=True)
  Set wb2 = Workbooks("MOLIENDA DE CEMENTO Y DESPACHOS FISICOS")
  Set sh2 = wb2.Sheets("PERDIDA Y FINURA CEMENTO 2021")
  'Set wb3 = Workbooks.Open("\\10.7.10.1\calidad\SEGUIMIENTO HORA-HORA\MOLIENDA DE CEMENTO Y DESPACHO.xlsx", ReadOnly:=True)
  Set wb3 = Workbooks("MOLIENDA DE CEMENTO Y DESPACHO")
  Set sh3 = wb3.Sheets("CEMENTO")
  Set dic = CreateObject("Scripting.Dictionary")
  '
  'Carga en una matriz y en un índice los Datos del libro 3
  a = sh3.Range("A2", sh3.Range("Q" & sh3.Range("A" & Rows.Count).End(3).Row)).Value2
  For i = 1 To UBound(a, 1)
    If Not IsError(a(i, 1)) Then
      dic(a(i, 1) & "|" & Val(a(i, 2)) & "|" & Right(a(i, 3), 1)) = a(i, 13) & "|" & a(i, 16)
    End If
  Next
  'Datos del libro2
  For i = 7 To sh2.Range("A" & Rows.Count).End(3).Row
    If Not IsError(sh2.Range("A" & i)) Then
      If sh2.Range("A" & i).Value = sh1.Range("C2").Value Then
        'col = IIf(Left(sh2.Range("C" & i).Value, 1) = "M", WorksheetFunction.Choose(Val(Right(sh2.Range("C" & i).Value, 1)), "", "", "C", "L", "U"), "")
        Select Case sh2.Range("C" & i).Value
          Case "M3": col = "C"
          Case "M4": col = "L"
          Case "M5": col = "U"
          Case Else: col = ""
        End Select
        If col <> "" Then
          fila = 5
          Do While sh1.Cells(fila, col).Value <> ""
            fila = fila + 1
          Loop
          m = sh2.Cells(i, "B").Value * 1
          sh1.Cells(fila, col) = IIf(m < 12 Or m = 24, m Mod 24 & ":00 AM", m Mod 12 & ":00 PM")
          sh1.Cells(fila, Columns(col).Column + 1).Resize(1, 4).Value = sh2.Range("D" & i).Resize(1, 4).Value
          sh1.Cells(fila, Columns(col).Column + 5).Value = sh2.Range("J" & i).Value
          '
          llave = sh1.Range("C2").Value & "|" & m & "|" & Right(sh2.Range("C" & i).Value, 1)
          If dic.exists(llave) Then
            sh1.Cells(fila, Columns(col).Column + 6).Resize(1, 2).Value = Split(dic(llave), "|")
          End If
        End If
      End If
    End If
  Next
  '
  wb2.Close False
  wb3.Close False
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  '
  If sh1.Range("C5, L5, U5") = "" Then
    MsgBox "No hay datos reportados para este día"
  End If
End Sub

Excelente.

Como le hago para que los datos de so3 y cl se conviertan a numero?

Cambia esta línea:

sh1.Cells(fila, Columns(col).Column + 6).Resize(1, 2).Value = Split(dic(llave), "|")

Por estas:

sh1.Cells(fila, Columns(col).Column + 6).Value = Val(Split(dic(llave), "|")(0))
sh1.Cells(fila, Columns(col).Column + 7).Value = Val(Split(dic(llave), "|")(1))

No me funciono, pero veo que se esta pegando es con un espacio delenate

No me funciono me arroja otros datos diferentes

Ignorar esto "No me funciono, pero veo que se esta pegando es con un espacio delenate"

¿Ya te funciona?

No me funciona por el contrario se pegan otros datos y otros se duplican

¿Probaste con los archivos que me compartiste?

De acuerdo a los archivos que compartiste, explícame SOLAMENTE uno de los problemas, para ir avanzando.

La columna de SO3 y J del libro consulta hija Cemento ahí es donde tengo el problema  se pegan como texto. Al cambie la línea línea me copia otros valores

Yo tengo este ejemplo para el 17/01/2021, en la hoja Cemento de Molienda:

En la hoja Cemento de Consultas, después de la macro:

Eso es lo que yo supuse que debería poner. Y digo "supuse" porque no explicaste un ejemplo.

Si pudieras explicar un ejemplo de lo que debe poner.

Que pena no haberme dado a entender. La macro corre bien solo que hay datos que se pegan como texto por ende no me toma la fórmula de promedio.

Adjunto imagen

Mmm, funciona bien para mí. El problema, supongo, es que tú utilizas la coma (, ) como separador de millares. Reviso para ver cómo lo resuelvo.

Lo raro es que en el resto de datos no pasa.

Los otros datos pasan directo de la hoja a la hoja.

Pero estos datos los almaceno como un item de un índice. Pero al hacerlo, se almacenan como texto:

dic(a(i, 1) & "|" & Val(a(i, 2)) & "|" & Right(a(i, 3), 1)) = a(i, 13) & "|" & a(i, 16)

Dónde modificamos?

No lo he probado, porque tengo que cambiar mi configuración regional y de excel a ( ; )

Prueba con esto:

sh1.Cells(fila, Columns(col).Column + 6).Value = Val(Split(dic(llave), "|")(0)) * 1
sh1.Cells(fila, Columns(col).Column + 7).Value = Val(Split(dic(llave), "|")(1)) * 1

Ahora queda como numero pero extrae los datos que no son.

Mira

Los datos no cambian, revisa el formato de decimales en la celda.

No me dado a entender, soy mejor explicando integrales y ecuaciones diferenciales je je.

Me pase a otro computador de la compañía y con la primera lines original me da el error de texto y con las nuevas líneas me queda como numero pero valores no correspondientes a los solicitado.

Cuando intento cambiar el formato con la primera opción no me cambia a ningún formato, solo si escibo el dato si lo hace.

Ya te entendí. A mí me funciona correctamente la macro.

Dicho sea de paso me gustaría que pusieras un ejemplo de lo que debe poner. Solamente pones un pedazo de hoja. Yo te mostré un ejemplo completo y no son mis datos, ni mi proyecto.

Yo tengo este ejemplo para el 17/01/2021, en la hoja Cemento de Molienda:

En la hoja Cemento de Consultas, después de la macro:

Buenas noches, Dante

Acabo de llegar a mi casa y he probado la macro y me presenta el mismo problema de texto.

Te adjunto las imágenes.

Ejemplo para el 17/01/2021, en la hoja Cemento de Molienda:

En la hoja Cemento de Consultas, después de la macro:

Si te das cuenta todo corre perfecto pero las columnas en mención tiene el problema de texto

Voy a configurar mi equipo para que el punto y coma se mi separador de decimales.

Y ya te digo.

Ok gracias

Listo, prueba la siguiente:

Sub CEMENTO()
'Por Dante Amor
  '
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim wb2 As Workbook, wb3 As Workbook
  Dim i As Long, fila As Long
  Dim col As String, llave As String
  Dim m As Variant, a As Variant
  Dim dic As Object
  Dim pri As Double, seg As Double
  '
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  '
  Set sh1 = ThisWorkbook.Sheets("CEMENTO")
  sh1.Range("C5:J22, L5:S22, U5:AB22").ClearContents
  '
  Set wb2 = Workbooks.Open("\\10.7.10.1\calidad\SEGUIMIENTO HORA-HORA\MOLIENDA DE CEMENTO Y DESPACHOS FISICOS.xlsx", ReadOnly:=True)
  'Set wb2 = Workbooks("MOLIENDA DE CEMENTO Y DESPACHOS FISICOS")
  Set sh2 = wb2.Sheets("PERDIDA Y FINURA CEMENTO 2021")
  Set wb3 = Workbooks.Open("\\10.7.10.1\calidad\SEGUIMIENTO HORA-HORA\MOLIENDA DE CEMENTO Y DESPACHO.xlsx", ReadOnly:=True)
  'Set wb3 = Workbooks("MOLIENDA DE CEMENTO Y DESPACHO")
  Set sh3 = wb3.Sheets("CEMENTO")
  Set dic = CreateObject("Scripting.Dictionary")
  '
  'Carga en una matriz y en un índice los Datos del libro 3
  a = sh3.Range("A2", sh3.Range("Q" & sh3.Range("A" & Rows.Count).End(3).Row)).Value2
  For i = 1 To UBound(a, 1)
    If Not IsError(a(i, 1)) Then
      dic(a(i, 1) & "|" & Val(a(i, 2)) & "|" & Right(a(i, 3), 1)) = a(i, 13) & "|" & a(i, 16)
    End If
  Next
  'Datos del libro2
  For i = 7 To sh2.Range("A" & Rows.Count).End(3).Row
    If Not IsError(sh2.Range("A" & i)) Then
      If sh2.Range("A" & i).Value = sh1.Range("C2").Value Then
        'col = IIf(Left(sh2.Range("C" & i).Value, 1) = "M", WorksheetFunction.Choose(Val(Right(sh2.Range("C" & i).Value, 1)), "", "", "C", "L", "U"), "")
        Select Case sh2.Range("C" & i).Value
          Case "M3": col = "C"
          Case "M4": col = "L"
          Case "M5": col = "U"
          Case Else: col = ""
        End Select
        If col <> "" Then
          fila = 5
          Do While sh1.Cells(fila, col).Value <> ""
            fila = fila + 1
          Loop
          m = sh2.Cells(i, "B").Value * 1
          sh1.Cells(fila, col) = IIf(m < 12 Or m = 24, m Mod 24 & ":00 AM", m Mod 12 & ":00 PM")
          sh1.Cells(fila, Columns(col).Column + 1).Resize(1, 4).Value = sh2.Range("D" & i).Resize(1, 4).Value
          sh1.Cells(fila, Columns(col).Column + 5).Value = sh2.Range("J" & i).Value
          '
          llave = sh1.Range("C2").Value & "|" & m & "|" & Right(sh2.Range("C" & i).Value, 1)
          If dic.exists(llave) Then
            pri = Split(dic(llave), "|")(0)
            seg = Split(dic(llave), "|")(1)
            sh1.Cells(fila, Columns(col).Column + 6).Value = pri
            sh1.Cells(fila, Columns(col).Column + 7).Value = seg
          End If
        End If
      End If
    End If
  Next
  '
  wb2.Close False
  wb3.Close False
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  '
  If sh1.Range("C5, L5, U5") = "" Then
    MsgBox "No hay datos reportados para este día"
  End If
End Sub

Buenas noches, Dante.

Perfecto, eso va más allá de mis pequeños conocimientos en vía.

Inquietud cuando colocas End(3).Row que significa.

Muchas gracias por tu apoyo.

Revisa la siguiente respuesta:

Duda en la expresión o sintaxis .end(3) o end(xlup) 

¡Gracias! 

Bue dia, Dante

Todo quedo ok. imagínate que se me quedo por fuera una hoja de cemento que se llama Mix Puzolanico y los datos deben ir en el cuadro de Z4 que es donde solo se produce este cemento. Opte por copiar una de las macros y llamarla para que se ejecute.

Se podria ingresar en la misma macro de cemento? 

Crea la nueva pregunta y lo reviso.

Ok ya tengo otra pregunta en el foro

Buenas noches, Dante

Tengo inconvenientes con los datos del primer día de cada mes, de los datos de SO3 Y CL.

No los estra pegando, pero el resto de días si los trae.

Crea la nueva pregunta con todo el detalle, tal vez tenga que revisar tus datos.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

Sumar dos filas distintas mayor a 0

Quiero sumar dos filas separadas por ejemplo fila 5 de A4 a J4 y fila 10 de A4 a J4, cada fila tiene resultados positivos o negativos, quiero que me sume en la celda B3 por ejemplo los datos positivos y en la celda C3 los datos negativos. Solo se...
2 respuestas

Filtrar ultima fecha según el criterio de una celda

Tengo una tabla de excel con la siguiente información Columna A el código del equipo. (Código único para cada equipo) Columna B la fecha en que se realizo la ultima revisión. Columna C el nombre del equipo. Columna D El tipo de revisión (preventivo,...
2 respuestas

Ocultar entorno access navegar por formularios e informes

Quiero ocultar el entorno de access pero que todo funcione tanto formulario como informes y que el icono salga en la barra de tareas
1 respuesta

Cómo hacer un filtro múltiple en formulario Excel?

Tengo un formulario en Excel con 5 combos combinado(Tipo, Año, Mes, servicio y Especialidad) y un cuadro de lista. La idea es que al seleccionar un valor en el cuadro combinado Tipo, en el cuadro de lista se me filtren los registros con ese valor,...
2 respuestas

Como poder bloquear tablas de access

Tengo un sistema dividido tablas y los formulario y quiero evitar que puedan entrar a las tablas así evito que modificquen algo
2 respuestas

Suma en un formulario de Excel

Estoy realizando un formulario, el cual al salir del ultimo texbox me sume los anteriores, he usado el siguiente código Private Sub base0_Change() On Error Resume Next Me.totalfactura = Round((Me.base0 + Me.base10 + Me.base21 + Me.base4 + Me.base5) +...
2 respuestas

Me pide contraseña al cerrar la base de datos

Hoy me ha ocurrido una cosa que no me ha pasado nunca, al cerrar la BD me pide contraseña. He mirado todo lo que se me ha ocurrido y no doy con lo que puede ser. Solo me ocurre con una BD en concreto, y que no he hecho nada en particular en la misma....
2 respuestas

Copiar dato de una celda para filtrar una tabla en otra hoja

En la primera hoja tengo una tabla con datos que alimenta otra tabla que se encuentra en una segunda hoja. Quisiera una macro que copie el contenido de la celda que tenga seleccionada, después ir la segunda hoja y filtrar ese dato en la tabla que ahí...
2 respuestas

Pasar de hoja resumen a plantilla de factura

Tengo un Excel, con un hoja resumen de datos, y lo que quisiera hacer, es que me pasara los datos que tengo en cada línea de la hoja resumen de forma de forma automática, a diferentes hojas de excel del mismo libro, en unas celdas concretas,...
3 respuestas

Access 2013 - Formulario para logear usuarios con contraseña

Estoy planeando agregarle a mi base de datos, un formulario para que logueen distintos usuarios. He estado viendo videos y me doy una idea. Pero mi base de datos está dividida en front y back end, he leído por ahí que eso puede ser un problema al...
3 respuestas