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.

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

Macro copiar hoja y cambiarle nombre al MES siguiente del array?

Seria posible crear una macro que copie una hoja "MES (tipo)" y que la nueva hoja copiada se llamase "MES ENERO", y que al ejucutar nuevamente la macro copiase la hoja "MES (tipo)" y que la nueva hoja se llamase "MES FEBRERO", y asi sucesivamente...
1 respuesta

Excel VBA Macro Acregar Símbolo "/" para convertir Fecha

Podrán sugerirme Algún código que inserte "/", en celda activa, para que excel lo tome como fecha. Ejemplo: Celda B3 Texto "1022024" Solución: Celda B3 Modificada: 01/02/2024
2 respuestas

¿Cómo separo dos números que se encuentran en una sola celda de excel?

En una celda de excel se encuentran dos cantidades separadas por un guion. Quisiera separar el primer número en una segunda celda y el segundo número en una tercer celda. Ejemplo: A 1 48,264 - 65,371 2 55,555 - 66,666 3 . . . Debería quedar así: A B...
2 respuestas

Al seleccionar celda extraer sus dígitos automáticamente

Necesito dos favores, la idea es que al seleccionar una celda numérica de 4 dígitos del rango "af1;aj42" esta automáticamente extraiga sus cifras a la columna "a1, b1, c1, d1" como se muestra en la imagen Y lo segundo como puedo quitarle el msgbox a...
2 respuestas

Se puede agregar voz a Excel

Tengo una pantalla de vuelo de vuelo donde anotó despegues y arribos, Quiero que cada vez que se produzca un despegue y se agregue hora o aterrice alguno y se ponga la hora, excel diga o se escuche atención Aterrizaje o Atención despegue.
3 respuestas

Gráfico Comparativo por Semanas, en Power Bi.

Espero se encuentren muy bien. Tengo una tabla en Power BI con fechas, códigos, costos y cantidades. La necesidad que tengo es de crear un gráfico o tabla donde pueda comparar y analizar el comportamiento de los costos y las cantidades de un código...
1 respuesta

En una lista para pedidos tengo varios formularios

En una lista para pedidos con varios formularios la vengo usando desde hace tiempo sin ningún problema pero hace días la abrí para hacer un pedido y al pisar en el cuadro donde apunta la flecha para que me abra un otro cuadro donde coloco ciertos...
2 respuestas

Código VBA para crear un botón y guardar en PDF

Tengo un archivo word con 7 capturas, una en cada página (1-7), cual seria el código para crear un botón en la barra de herramientas de acceso rápido para convertir en PDF cada página. El resultado seria 7 pdf.
2 respuestas

Como evitar que se duplique un dato en la base de datos

Trato que al ingresar los datos a la base de datos si en la columna "B" DNI es una cifra que ya esta en dicha base me lo indique en un Msgbox "El Dato ya existe" Esta es la macro que tengo en el botón Aceptar Private Sub Aceptar_Click()...
2 respuestas

Detectar si he marcado Celda dentro de un Rango de Excel.

Tengo un Rango en Hoja Excel: RgoDatos >> $B$3:$V$39 Quiero detectar si la celda que selecciono está dentro de ese Rango Si no está que por omisión me marque B3.
1 respuesta