Cargar datos en hojas según día y familias en Excel
Solicito su ayuda nuevamente lo que necesito son cuadros de requerimientos uno de perecibles y otro de no perecibles pero de toda una semana de lunes a domingo.
Por ejemplo en la hoja "PROD_BD" filtre primero por día primero "LUNES" y luego familia en este caso solo hay dos "PERECIBLES" y "NO PERECIBLES" y que luego estos datos se copien según, los productos perecibles se copien en la hoja "PERECIBLES" y los productos no perecibles en la hoja no perecibles y que siga el ciclo de toda la semana de LUNES a DOMINGO el código que le he ingresado es muy largo por ello solicito su ayuda para poder reducir el código
Este es la hoja principal y como puede ver están en la columna "P" los días de la semana y en la columna "O" la familia
Este es código que estado utilizado pero es muy largo para lograr el resultado me puede ayudar a simplificarlo
dato = "LUNES"
' dato
Hoja8.ListObjects("TABLA1").Range.AutoFilter field:=16, Criteria1:=dato, Operator:=xlFilterValues
Hoja8.Select
Range("Tabla1[DIA SEMANA]").Select
Selection.Copy
Sheets("Perecibles").Select
Range("a4").Select
countult = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("PROD_BD").Select
Range("Tabla1[DESCRIPCIÓN]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Perecibles").Select
Sheets("Perecibles").Select
Range("a4").Select
countult = Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row
Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Select
'Range("C5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("PROD_BD").Select
Range("Tabla1[RECETAS]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Perecibles").Select
Sheets("Perecibles").Select
Range("a4").Select
countult = Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Select
'Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("PROD_BD").Select
Range("Tabla1[U.M.]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Perecibles").Select
Sheets("Perecibles").Select
Range("a4").Select
countult = Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row
Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Select
'Range("D5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("PROD_BD").Select
Range("Tabla1[GUÍA DE PEDIDO]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Perecibles").Select
Sheets("Perecibles").Select
Range("a4").Select
countult = Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Row
Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Select
'Range("E5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Call Lineay este es el resultado que he obtenido el código hace que filtre el día de la semana y la familia y que luego esta información se pegue en la hojas si los productos son perecibles en la hoja que corresponden y los no perecibles en la hoja que corresponde este código es solo para filtrar 1 día faltan agregar los otros día de la semana pero seria mucho mas largo me puede ayudar a simplificarlo
Gracias por la atención prestada
Slds
Robert
1 Respuesta
H o l a:
Te anexo la macro
Sub CopiarSemana()
'Por.Dante Amor
Set h1 = Sheets("PROD_BD")
Set h2 = Sheets("Perecibles")
Set h3 = Sheets("No Perecibles")
u = h1.ListObjects("TABLA1").Range.Rows.Count
dias = Array("LUNES", "MARTES", "MIERCOLES", "JUEVES", "VIERNES", "SABADO", "DOMINGO")
For d = LBound(dias) To UBound(dias)
For i = 2 To h1.ListObjects("TABLA1").Range.Rows.Count
If h1.Cells(i, "K") = dias(d) Then
If h1.Cells(i, "J") = "PERECIBLES" Then
CopiaDatos h1, i, h2
ElseIf h1.Cells(i, "J") = "NO PERECIBLES" Then
CopiaDatos h1, i, h3
End If
End If
Next
Next
End Sub
'
Sub CopiaDatos(h1, i, hoja)
'Por.Dante Amor
u = hoja.Range("A" & Rows.Count).End(xlUp).Row + 1
hoja.Cells(u, "A") = h1.Cells(i, "K")
hoja.Cells(u, "B") = h1.Cells(i, "I")
hoja.Cells(u, "C") = h1.Cells(i, "F")
hoja.Cells(u, "D") = h1.Cells(i, "E")
hoja.Cells(u, "E") = h1.Cells(i, "B")
End Sub
