Macro copiar celdas con condición

[ToniTF81]

Buenas, estoy intentando crear un botón que me copie unas celdas determinadas de un libro a otro y después que me vuelva a copiar éstas celdas de una hoja a otra. la primera parte la tengo resuelta pero ahora no se por donde seguir.

Así tengo el código de momento:

Sub CopiarCeldas()

Dim Pesadas As Workbook
Dim Destino As Workbook

Application.ScreenUpdating = False

Set Pesadas = Workbooks.Open("Z:\D.Calidad y Tecnica\2_Gestion de CALIDAD\Patri\TONI\pesadas.xls")

Workbooks("pesadas.xls").Worksheets("BCT2DB").Range("B1:H7398").Copy Workbooks("destino.xlsm").Worksheets("BD").Range("A2")

Pesadas.Close False

End Sub

La pregunta en cuestión es que código necesito para copiar los valores de unas celdas de una hoja a otra en una columna siempre y cuando el valor de la columna de al lado sea uno específico, es decir, si A=4 copiar el valor de la celda de al lado en la hoja 2, si A=5 copiar el valor de la celda en la hoja 3, etc...

Gracias de antemano!

Un saludo

destino00.xlsx

[Dr Hyde]

checa la macro solo da clik en el boton

destino00.xlsm

[ToniTF81]

Hola, ante todo, gracias por la ayuda. Tengo un problema con éste archivo... resulta que cuando le meto la tabla de datos de unos 7000 valores, cuando ejecuto la macro copia perfectamente, pero no separa bien los valores, en unas hojas si pero en otras se mezclan.

Adjunto el archivo comprimido en 2 partes, a ver si alguien puede descifrarlo. Gracias!!

destino00.zip

destino00.z01

[Dr Hyde]

viendo tus datos me doy cuenta que tu infromacion no esta ordenada y que tienes valores numericos como textos, ambas cosas estan provocando que el resultado sea distinto al esperado, esta macro hace primero la conversion de texto a valor, despues hace un ordenamiento y finalmente hace la copia a la hoja que le corresponde, nota si la hoja no existe la crea.

Sub copiar()

Set datos = ActiveSheet.UsedRange

matriz = datos.Columns(1)

For i = 1 To datos.Rows.Count
   matriz(i, 1) = Val(matriz(i, 1))
Next i

Range(datos.Columns(1).Address) = matriz

datos.Sort key1:=Range(datos.Columns(1).Address), order1:=xlAscending
maxi = WorksheetFunction.Max(datos.Columns(1))
mini = WorksheetFunction.Min(datos.Columns(1))

For j = mini To maxi
On Error Resume Next
    Set hd = Worksheets("numero_" & j)
    
        If Err.Number = 9 Then
            Sheets.Add
            ActiveSheet.Name = "numero_" & j
            Sheets("bd").Select
        End If
    On Error GoTo 0
    cuenta = WorksheetFunction.CountIf(datos.Columns(1), j)
    fila = WorksheetFunction.Match(j, datos.Columns(1), 0)
    
    Set Destino = hd.Range("a1").Resize(cuenta, datos.Columns.Count)
    datos.Rows(fila).Resize(cuenta, datos.Columns.Count).Copy Destino
Next j
End Sub

[ToniTF81]

Guay!, al final he hecho 2 macros, una que ordena y otra que copia gracias a tu ayuda. Solo una duda más, necesito que el pegado sea especial solo valores. ¿Cómo lo hago?.

Aquí el código:

Sub copiar()
Dim unicos As New Collection
Set bd = Worksheets("bd")
Set datos = bd.UsedRange

For i = 1 To datos.Rows.Count
    num = datos.Cells(i, 1)
    On Error Resume Next
        unicos.Add num, CStr(num)
    On Error GoTo 0
Next i

a = 1
For Each unico In unicos
    cuenta = WorksheetFunction.CountIf(datos.Columns(1), unico)
    fila = WorksheetFunction.Match(unico, datos.Columns(1), 0)
    Set hoja = Worksheets("hoja" & a + 1)
    datos.Rows(fila).Resize(cuenta, datos.Columns.Count).Copy hoja.Range("a12")
    a = a + 1
Next unico
MsgBox ("copia realizada")
End Sub

 

[Dr Hyde]

cambia la instruccion de copia por estas dos lineas

datos.Rows(fila).Resize(cuenta, datos.Columns.Count).Copy 

hoja.Range("a12") .PasteSpecial xlPasteValues

[ToniTF81]

Hace 13 horas, Dr Hyde dijo:

cambia la instruccion de copia por estas dos lineas

datos.Rows(fila).Resize(cuenta, datos.Columns.Count).Copy 

hoja.Range("a12") .PasteSpecial xlPasteValues

Ya lo había probado, pero me sale "error de compilación: se esperaba fin de la instrucción"...

[Dr Hyde]

esta es tu macro modificada, le hice un cambio muy leve por un dato que parecia redundante.

Sub CopiarCeldas()

Dim unicos As New Collection
Set bd = Worksheets("bd")
Set datos = bd.UsedRange

For i = 1 To datos.Rows.Count
    num = datos.Cells(i, 1)
    On Error Resume Next
        unicos.Add num, CStr(num)
    On Error GoTo 0
Next i

For Each unico In unicos
    cuenta = WorksheetFunction.CountIf(datos.Columns(1), unico)
    fila = WorksheetFunction.Match(unico, datos.Columns(1), 0)
    Set hoja = Worksheets("hoja" & unico)
    datos.Rows(fila).Resize(cuenta).Copy
    hoja.Range("a12").PasteSpecial xlPasteValues
Next unico
MsgBox ("copia realizada")
End Sub

[ToniTF81]

Hola y gracias de nuevo. Me sale error de subíndice fuera de intervalo de nuevo en

Set hoja = Worksheets("hoja" & unico)

No se si tendrá que ver con haberle quitado el a=1 y a= a+1 ...