Copiar un dato de una hoja a otra a través de una macro

Tengo una hoja llamada "Visitas" y en ella ejecuto una macro llamada "Registros"

La macro es esta:

Sub REGISTROS()
'Act.Por.Dante Amor
    Application.Visible = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Set h1 = Sheets("VISITAS")
    Set h2 = Sheets("CARTERA")
    Set h4 = Sheets("CLIENTES")
    '
    u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
    h1.Range("C5:C14").Copy: h2.Range("A" & u).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    h1.Range("F5:F14").Copy: h2.Range("K" & u).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    h1.Range("F2").Copy: h2.Range("U" & u).PasteSpecial Paste:=xlPasteValues, Transpose:=False
    h2.Range("V3:Y3").Copy h2.Range("V" & u)
    h2.Range("F" & u).TextToColumns Destination:=h2.Range("Z" & u), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 2), Array(1, 1), Array(4, 1)), TrailingMinusNumbers:=True
    h2.Range("AC3").Copy h2.Range("AC" & u)
    h2.Range("H" & u).TextToColumns Destination:=h2.Range("AD" & u), _
        DataType:=xlDelimited, TextQualifier:=xlNone, ConsecutiveDelimiter:=True, Space:=True, _
        FieldInfo:=Array(Array(1, 2), Array(2, 2)), TrailingMinusNumbers:=True
    h2.Range("AF" & u) = "=TEXT(RC[-31],""yyyy"")"
    h2.Range("AG" & u) = "=TEXT(RC[-32],""mmmm"")"
    h2.Range("AH" & u) = "=IF(RC[-4]="""","""",IF(RC[-4]=""plan"",""Particulares"",RC[-3]))"
     'aquí nueva instrucción
    '
    h1.Unprotect Password:="0976342842"
    H1. Range("F5:F7"). ClearContents
    H1. Range("F10:F12"). ClearContents
    H1. Range("F14"). ClearContents
    H1. Range("C6:C7"). ClearContents
    H1. Range("C9:C12"). ClearContents
    H1. Range("C14"). ClearContents
    h1.Range("F2") = h1.Range("F2") + 1
    h1.Protect Password:="0976342842"
    Application.ScreenUpdating = True
    Application.Visible = True
    ActiveWorkbook.Save
    Dim FileWsh As Object
    Set FileWsh = CreateObject("Scripting.FileSystemObject")
    MiVolumen = Hex$(FileWsh.Drives("C").SerialNumber)
    Select Case MiVolumen
        Case "9A42EB79"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheets("CARTERA").Visible = True
    Sheets("CARTERA").Copy
    ruta = "\\DERMATOLOGA1\manager\Consultorio\"
    ActiveWorkbook.SaveAs ruta & "Registros.xlsx", FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close
    Sheets("CARTERA").Visible = xlVeryHidden
     Case Else
    End Select
    Set FileWsh = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
End Sub

La macro funciona muy bien pero quisiera agregarle una nueva instrucción donde dice "Aqui nueva instrucción".

La instrucción que quiero ahí es que busque el dato contenido en la celda "C7" de la hoja "VISITAS" en la columna "C" de la hoja "Clientes" y cuando lo encuentre que me copie el dato contenido en la columna "F" de esa misma fila, en la columna "AW" de la hoja "CARTERA". Quiero que me copie ese dato con la instrucción, copiar valores.

1 respuesta

Respuesta
1

Te anexo el código:

 'aquí nueva instrucción
    Set b = h4.Columns("C").Find(h1.[C7], lookat:=xlWhole)
    If Not b Is Nothing Then
        h2.Range("AW" & u) = h4.Cells(b.Row, "F")
    End If
    '

Sal u dos

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas