URGE solucionar macro
Buenas tardes.
Con esta macro pretendo recopilar todos los valores (códigos numéricos) existentes en las celdas B13 a B55 de todas las hojas de un libro, pero el problema es que no me respeta el formato de los valores de esas celdas. Por ej: un dato es el 0022 y me arroja solo 22, otro ej: el valor 1-1208 y me arroja Jan-08. ¿Cómo modifico la macro para que me respete ese valor?
Gracias.
Sub MP()
Dim n As Byte
Application.ScreenUpdating = False
Worksheets.Add Before:=Worksheets(1)
Range("a1:b1").Value = "Materia Prima"
For n = 2 To Worksheets.Count
With Worksheets(n)
With .Range(.[b13], .[b55])
[a65536].End(xlUp).Offset(1).Resize(.Rows.Count).Value = .Value
End With
End With
Next
Range([a1], [a65536].End(xlUp)).AdvancedFilter xlFilterCopy, , [b1], 1
[a1].EntireColumn.Delete
[a1].Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
Debug.Print ActiveSheet.UsedRange.Address
ActiveSheet.Name = "Listado general"
End Sub
Con esta macro pretendo recopilar todos los valores (códigos numéricos) existentes en las celdas B13 a B55 de todas las hojas de un libro, pero el problema es que no me respeta el formato de los valores de esas celdas. Por ej: un dato es el 0022 y me arroja solo 22, otro ej: el valor 1-1208 y me arroja Jan-08. ¿Cómo modifico la macro para que me respete ese valor?
Gracias.
Sub MP()
Dim n As Byte
Application.ScreenUpdating = False
Worksheets.Add Before:=Worksheets(1)
Range("a1:b1").Value = "Materia Prima"
For n = 2 To Worksheets.Count
With Worksheets(n)
With .Range(.[b13], .[b55])
[a65536].End(xlUp).Offset(1).Resize(.Rows.Count).Value = .Value
End With
End With
Next
Range([a1], [a65536].End(xlUp)).AdvancedFilter xlFilterCopy, , [b1], 1
[a1].EntireColumn.Delete
[a1].Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
Debug.Print ActiveSheet.UsedRange.Address
ActiveSheet.Name = "Listado general"
End Sub
1 Respuesta
Respuesta de cristianccb
1
Este trozo de código... hay que adaptarlo al tuyo, pero la idea es simple, realiza un pegado especial de "todo" y te copiará exactamente lo que tienes.
Sheets(n).Select
Range("B13:B55").Select
Selection. Copy
Sheets("hoja nueva"). Select ' denominé hoja nueva a aquella donde deseas pegar los datos.
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets(n).Select
Range("B13:B55").Select
Selection. Copy
Sheets("hoja nueva"). Select ' denominé hoja nueva a aquella donde deseas pegar los datos.
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Gracias por tu respuesta, pero no he podido colocarla en la macro, no entiendo bien como acomodarlo en el arreglo. ¿No habrá forma de modificar las lineas :
[a65536].End(xlUp).Offset(1).Resize(.Rows.Count).Value = .Value
o
Range([a1], [a65536].End(xlUp)).AdvancedFilter xlFilterCopy, , [b1], 1
para poder resolver el problema?
Gracias de nuevo por tu interés
[a65536].End(xlUp).Offset(1).Resize(.Rows.Count).Value = .Value
o
Range([a1], [a65536].End(xlUp)).AdvancedFilter xlFilterCopy, , [b1], 1
para poder resolver el problema?
Gracias de nuevo por tu interés
Te propongo el siguiente código. Al ejecutar la macro se agrega una nueva hoja y en esa hoja va añadiendo el rango b13:b55 recorriendo cada una de las hojas... y lo que querías.. mantiene el formato. Pruébala y me cuentas. Saludos
Sub Copiarangoaotrahoja()
Dim n As Integer
Worksheets.Add Before:=Worksheets(1)
Sheets(1).Select
Range("a1:b1").Value = "Materia Prima"
For n = 2 To Worksheets.Count
With Worksheets(n)
With .Range(.[b13], .[b55])
.Offset(1, 0).Resize(.Rows.Count - 1).Copy _
Destination:=Worksheets(ActiveSheet.Name).Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
'End With
End With
End With
Next
End Sub
Sub Copiarangoaotrahoja()
Dim n As Integer
Worksheets.Add Before:=Worksheets(1)
Sheets(1).Select
Range("a1:b1").Value = "Materia Prima"
For n = 2 To Worksheets.Count
With Worksheets(n)
With .Range(.[b13], .[b55])
.Offset(1, 0).Resize(.Rows.Count - 1).Copy _
Destination:=Worksheets(ActiveSheet.Name).Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
'End With
End With
End With
Next
End Sub
Gracias, si mantiene el formato tal cual es, el único problema ahora es que no me elimina los que se repiten, ¿cómo lo añadiría a tu código?
Sólo hay que añadir la última parte de tu código fuera del ciclo for... Saludos.
Sub Copiarangoaotrahojav2()
Dim n As Integer
Worksheets.Add Before:=Worksheets(1)
Sheets(1).Select
Range("a1:b1").Value = "Materia Prima"
For n = 2 To Worksheets.Count
With Worksheets(n)
With .Range(.[b13], .[b55])
.Offset(1, 0).Resize(.Rows.Count - 1).Copy _
Destination:=Worksheets(ActiveSheet.Name).Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
'End With
End With
End With
Next
Range([a1], [a65536].End(xlUp)).AdvancedFilter xlFilterCopy, , [b1], 1
[a1].EntireColumn.Delete
[a1].Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
Debug.Print ActiveSheet.UsedRange.Address
ActiveSheet.Name = "Listado general"
End Sub
Sub Copiarangoaotrahojav2()
Dim n As Integer
Worksheets.Add Before:=Worksheets(1)
Sheets(1).Select
Range("a1:b1").Value = "Materia Prima"
For n = 2 To Worksheets.Count
With Worksheets(n)
With .Range(.[b13], .[b55])
.Offset(1, 0).Resize(.Rows.Count - 1).Copy _
Destination:=Worksheets(ActiveSheet.Name).Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
'End With
End With
End With
Next
Range([a1], [a65536].End(xlUp)).AdvancedFilter xlFilterCopy, , [b1], 1
[a1].EntireColumn.Delete
[a1].Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
Debug.Print ActiveSheet.UsedRange.Address
ActiveSheet.Name = "Listado general"
End Sub
Gracias, con tu macro y ciertas modificaciones logre lo que quería.
El único detalle es que me repetía algunos valores, gracias de nuevo.
El único detalle es que me repetía algunos valores, gracias de nuevo.
