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 SubLa 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 de Dante Amor
1