Macro para extraer datos de otros libros según la fecha asignada
Tema.
Tengo una macro que me extrae los datos de otro libro pero tengo problemas que ver celdas vacías en la columnas de la fecha me salta un error y no sigue haciendo la actualización, además no he podido enlazar otros datos del otro libro. Si es posible mejorar lo que he hecho seria genial para que haga el trabajo más rápido.
En espera de sus comentarios.
Sub CEMENTO()
Set jh = Sheets("CEMENTO")
jh.Activate
Range(jh.Cells(5, "C"), jh.Cells(22, "I")).Select
Selection.ClearContents
Range(jh.Cells(5, "K"), jh.Cells(22, "Q")).Select
Selection.ClearContents
Range(jh.Cells(5, "S"), jh.Cells(22, "Y")).Select
Selection.ClearContents
Workbooks.Open Filename:="\\10.7.10.1\calidad\SEGUIMIENTO HORA-HORA\MOLIENDA DE CEMENTO Y DESPACHOS FISICOS.xlsx", ReadOnly:=True
Set jhc = Sheets("PERDIDA Y FINURA CEMENTO 2021")
jhc.Activate
jhc.Cells(7, "A").Select
jhc.Cells(7, "A").End(xlDown).Select
Fila = ActiveCell.Row
Target = 0
Filam1 = 5
Filam2 = 5
Filam3 = 5
Do While Target = 0
If jhc.Cells(Fila, "A") = jh.Cells(2, "C") Then
If jhc.Cells(Fila, "C") = "M3" Then
jh.Activate
jh.Cells(Filam1, "C") = jhc.Cells(Fila, "B") * 1
If jh.Cells(Filam1, "C") <= 12 Then
jh.Cells(Filam1, "C") = jh.Cells(Filam1, "C") & " AM"
Else
If jh.Cells(Filam1, "C") - 12 = 0 Then
jh.Cells(Filam1, "C") = "0:00 AM"
Else
jh.Cells(Filam1, "C") = (jh.Cells(Filam1, "C") - 12) & " PM"
End If
End If
For i = 4 To 9
jh.Cells(Filam1, i) = jhc.Cells(Fila, i - 1)
Next i
Filam1 = Filam1 + 1
Else
If jhc.Cells(Fila, "C") = "M4" Then
jh.Activate
jh.Cells(Filam2, "K") = jhc.Cells(Fila, "B") * 1
If jh.Cells(Filam2, "K") <= 12 Then
jh.Cells(Filam2, "K") = jh.Cells(Filam2, "K") & " AM"
Else
If jh.Cells(Filam2, "K") - 12 = 0 Then
jh.Cells(Filam2, "K") = "0:00 AM"
Else
jh.Cells(Filam2, "K") = (jh.Cells(Filam2, "K") - 12) & " PM"
End If
End If
For i = 12 To 17
jh.Cells(Filam2, i) = jhc.Cells(Fila, i - 9)
Next i
Filam2 = Filam2 + 1
Else
If jhc.Cells(Fila, "C") = "M5" Then
jh.Activate
jh.Cells(Filam3, "S") = jhc.Cells(Fila, "B") * 1
If jh.Cells(Filam3, "S") <= 12 Then
jh.Cells(Filam3, "S") = jh.Cells(Filam3, "S") & " AM"
Else
If jh.Cells(Filam3, "S") - 12 = 12 Then
jh.Cells(Filam3, "S") = 0 & " AM"
Else
jh.Cells(Filam3, "S") = (jh.Cells(Filam3, "S") - 12) & " PM"
End If
End If
For i = 15 To 20
jh.Cells(Filam3, i) = jhc.Cells(Fila, i - 17)
Next i
Filam3 = Filam3 + 1
End If
End If
End If
End If
jhc.Activate
If Fila < 3 Then
Target = 1
End If
Fila = Fila - 1
Loop
If jh.Cells(5, "C") = Empty And jh.Cells(5, "K") = Empty And jh.Cells(5, "S") = Empty Then
MsgBox ("No hay datos reportados para este día")
End If
jhc.Activate
ActiveWindow.Close savechanges:=False
jh.Activate
jh.Range("C5:I22").Select
ActiveWorkbook.Worksheets("CEMENTO").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("CEMENTO").Sort.SortFields.Add2 Key:=Range("C5"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("CEMENTO").Sort
.SetRange Range("C5:I22")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
jh.Range("K5:Q22").Select
ActiveWorkbook.Worksheets("CEMENTO").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("CEMENTO").Sort.SortFields.Add2 Key:=Range("K5"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("CEMENTO").Sort
.SetRange Range("K5:Q22")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
jh.Range("S5:Y22").Select
ActiveWorkbook.Worksheets("CEMENTO").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("CEMENTO").Sort.SortFields.Add2 Key:=Range("S5"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("CEMENTO").Sort
.SetRange Range("S5:Y22")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
De acuerdo.
En la columnas de la fecha me salta un error
¿En cuál línea de la marco tienes el error?
Y ayúdame con un ejemplo. No tengo idea de tus datos, no tengo idea de cómo están, no tengo idea de valores van en cada celda.
Ayudaría mucho si eres más específico. Pon una imagen con ejemplos, utiliza datos genéricos, y explicas cuál es el problema.
El problema que tengo es cuando especifico una fecha por, y si en la columna fecha encuentra un vacío me lanza error.
Ahora me sale este error.
Como hago para enviarte los archivos.
Puedes subirlos a googledrive o dropbox y los compartes, pegas aquí el enlace.
Ok gracias.
Estos son los enlaces de googledrive:
https://drive.google.com/file/d/1WcpYWtsO64nvdGkAT-Z511CrUJuSCOLC/view?usp=sharing
https://drive.google.com/file/d/1iEKZBrpogzPefHCxuuJjO6UHzAPumd3V/view?usp=sharing
https://drive.google.com/file/d/1s7UzLvnlTlewiy-2hOdVPAG9kD2gXkVC/view?usp=sharing
Lo otro que me hace falta en copiar el datos del archivo químicos la columna SO3 y CL.
De acuerdo, reviso tus archivos, analizo la macro para ver qué hace y te ayudo a simplificarla, claro, además de resolver el problema; y también veo si puedo copiar los datos del archivo "químicos".
No tengo permisos para descargar los archivos, te envié las solicitudes.
Ya encontré el problema.
En esta línea tienes de 15 a 20
Tu contador i empieza en 15, pero le restas 17, entonces te queda la columna -2 y esa no existe por eso te envía error.
For i = 15 To 20 jh.Cells(filam3, i) = jhc.Cells(fila, i - 17)
Y debe ser de 20 a 25 (De la columna "T" a "Y")
For i = 20 To 25
Prueba nuevamente.
Excelente.
Que mejoras se le pueden hacer
Que mejoras se le pueden hacer
Cambia todo tu código por lo siguiente:
Sub CEMENTO()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim wb As Workbook
Dim i As Long, fila As Long
Dim col As String, m As Variant
'
Application.ScreenUpdating = False
Set sh1 = Sheets("CEMENTO")
sh1.Range("C5:I22, K5:Q22, S5:y22").ClearContents
'
Set wb = Workbooks.Open("\\10.7.10.1\calidad\SEGUIMIENTO HORA-HORA\MOLIENDA DE CEMENTO Y DESPACHOS FISICOS.xlsx", ReadOnly:=True)
Set sh2 = Sheets("PERDIDA Y FINURA CEMENTO 2021")
'
For i = 7 To sh2.Range("A" & Rows.Count).End(3).Row
If sh2.Range("A" & i).Value = sh1.Range("C2").Value Then
Select Case sh2.Range("C" & i).Value
Case "M3": col = "C"
Case "M4": col = "K"
Case "M5": col = "S"
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, 6).Value = sh2.Range("C" & i).Resize(1, 6).Value
End If
End If
Next
wb.Close False
Application.ScreenUpdating = True
If sh1.Range("C5, K5, S5") = "" Then
MsgBox "No hay datos reportados para este día"
End If
End Sub
Buenas noches,
Ok gracias ya pruebo y le comento
El problema ya fue resuelto. Y como valor agregado simplifiqué el código. Y sin duda es más rápido.
Crea una nueva pregunta para el tema de enlazar otro libro. Ahí explicas lo que necesitas.
