Extraer datos de tres hojas de un mismo libro

En esta ocasión resulta que deseo al igual que en el anterior hacer que la macro sea más corta y efiiente.

La idea es copiar los datos de has hojas crudo1, crudo2 y retenido del libro molienda de crudo al libro consultas calidad en la hoja molienda de crudo en cada molino.

Con dependencia de fecha y horas diferentes para los retenidos como la imagen.

En espera de sus comentarios

Adjunto los libros:

Molienda de crudo:

https://drive.google.com/file/d/1O7gD-enwPr2nPmh7TDXtt-5tt3IKvhbD/view?usp=sharing 

Consultas Calidad

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

1 Respuesta

Respuesta
2

La idea es copiar los datos de has hojas crudo1, crudo2 y retenido del libro molienda de crudo al libro consultas calidad en la hoja molienda de crudo

¿Los datos de la hoja "CRUDO1" en dónde se ponen, en Molino1)

¿Los datos de la hoja "CRUDO2" en dónde se ponen, en Molino2?

¿Los datos de la hoja "CRUDO1" en dónde se ponen?

Si señor crudo en molino 1 6 crudo en molino 2.

Los datos de crudo 1 y crudo 2 van en la hoja molienda de crudo del libro consultas

¿Los datos de la hoja "RETENIDO" en dónde se ponen?

En molino 1 y molino 2 de la hoja molienda de crudo de l libro consultas

De la hoja Retenido, ¿solamente este dato "% RET Malla 170 " se pone en la columna "RET 170"?

La hora y ret 170

Va la macro:

Private Sub CommandButton1_Click()
'MOLIENDA_CRUDO
  Dim sh1 As Worksheet, sh2 As Worksheet, wb As Workbook
  Dim i As Long, fila As Long, fila5 As Long, fila20 As Long
  Dim m As Variant, h As Variant, hojas As Variant
  Dim col As String
  '
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh1 = Sheets("MOLIENDA DE CRUDO")
  sh1.Range("C5:U17, C20:U32").ClearContents
  '
  Set wb = Workbooks.Open("\\10.7.10.1\calidad\SEGUIMIENTO HORA-HORA\MOLIENDA DE CRUDO.xlsx", ReadOnly:=True)
  'Set wb = Workbooks("MOLIENDA DE CRUDO")
  hojas = Array("CRUDO 1", 5, "C", "CRUDO 2", 20, "C", "RETENIDO", 1, "T")
  '
  For h = 0 To UBound(hojas) Step 3
    Set sh2 = wb.Sheets(hojas(h))
    fila = hojas(h + 1)
    col = hojas(h + 2)
    fila5 = 5: fila20 = 20
    For i = 2 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
          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")
          If col = "C" Then
            sh1.Cells(fila, "D") = sh2.Range("C" & i).Value
            sh1.Cells(fila, Columns("E").Column).Resize(1, 15).Value = sh2.Range("F" & i).Resize(1, 15).Value
          Else
            If sh2.Range("C" & i).Value = 1 Then fila = fila5: fila5 = fila5 + 1
            If sh2.Range("C" & i).Value = 2 Then fila = fila20: fila20 = fila20 + 1
            sh1.Cells(fila, col) = IIf(m < 12 Or m = 24, m Mod 24 & ":00 AM", m Mod 12 & ":00 PM")
            sh1.Cells(fila, "U") = sh2.Range("D" & i).Value
          End If
          fila = fila + 1
        End If
      End If
    Next i
  Next h
  'wb.Close False
  If sh1.Range("C5, C20") = "" Then
    MsgBox "No hay datos reportados para este día"
  End If
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Buenos días, Dante

Excelente más rápida que la que había realizado.

Me podrías ayudar con este tema, resulta que al realizar la comparación de fechas en el retenido cuando ve datos en fecha y vacion en horas me coloca las 12 am en todas la columna.

Como podría modificar esto.

Saludos,

¿Pero eso es una fórmula?

R ecuerda valorar la respuesta.

No es una fórmula, la idea es que l evaluar la fecha y sino ve dato lo colocar nada.

Le adjunto nuevamente las imágenes. Al correr la macro esta colovando el valor de 12 de las celdas vacías de la fecha.

Va la actualización:

Private Sub CommandButton1_Click()
'MOLIENDA_CRUDO
  Dim sh1 As Worksheet, sh2 As Worksheet, wb As Workbook
  Dim i As Long, fila As Long, fila5 As Long, fila20 As Long
  Dim m As Variant, h As Variant, hojas As Variant
  Dim col As String
  '
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set sh1 = Sheets("MOLIENDA DE CRUDO")
  sh1.Range("C5:U17, C20:U32").ClearContents
  '
  Set wb = Workbooks.Open("\\10.7.10.1\calidad\SEGUIMIENTO HORA-HORA\MOLIENDA DE CRUDO.xlsx", ReadOnly:=True)
  'Set wb = Workbooks("MOLIENDA DE CRUDO")
  hojas = Array("CRUDO 1", 5, "C", "CRUDO 2", 20, "C", "RETENIDO", 1, "T")
  '
  For h = 0 To UBound(hojas) Step 3
    Set sh2 = wb.Sheets(hojas(h))
    fila = hojas(h + 1)
    col = hojas(h + 2)
    fila5 = 5: fila20 = 20
    For i = 2 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
          If sh2.Range("B" & i) <> "" Then
            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")
            If col = "C" Then
              sh1.Cells(fila, "D") = sh2.Range("C" & i).Value
              sh1.Cells(fila, Columns("E").Column).Resize(1, 15).Value = sh2.Range("F" & i).Resize(1, 15).Value
            Else
              If sh2.Range("C" & i).Value = 1 Then fila = fila5: fila5 = fila5 + 1
              If sh2.Range("C" & i).Value = 2 Then fila = fila20: fila20 = fila20 + 1
              sh1.Cells(fila, col) = IIf(m < 12 Or m = 24, m Mod 24 & ":00 AM", m Mod 12 & ":00 PM")
              sh1.Cells(fila, "U") = sh2.Range("D" & i).Value
            End If
            fila = fila + 1
          End If
        End If
      End If
    Next i
  Next h
  'wb.Close False
  If sh1.Range("C5, C20") = "" Then
    MsgBox "No hay datos reportados para este día"
  End If
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub


¡Gracias! 

Quedó muy bueno. Le envío otra pregunta para tratar de dejar todo el informe listo.

V i s i t a:

Cursos de Excel y Macros

Recomendación del día:

[url=https://www.youtube.com/watch?v=j2sf0_ZCr7Y&t=635s]Generar archivos y enviar correo en automático
[/url]

Sal u dos

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas