Multireemplazo
Hola Amigo; estoy volviendo a ver la macro de multireemplazo que me enviaste ayer y sigo alucinando de lo bien que va, pero me pregunto si hay alguna manera de que la macro no me haga las preguntas de rangos y etc, ya que siempre utilizare los mismo rangos.
¿Es decir se puede poner en la macro las respuestas por defecto a las preguntas? Las respuestas serían estas:
1.- Dando 2 columnas de la tabla esta macro reemplazar un rango del usuario --- aceptar
2.- seleccione 2 columnas de la tabla y el texto de reemplazo -- $V$2:$W$275
3.- seleccione el rango para reemplazar ----- $P:$Q
4.- digite 1 para coincidencia exacta, 2 para parcial ----- 2
5.- Continuar o retroceder --- Sí
Imagino que si se podrá, pero yo por más que lo he intentado no me acaba de salir. ¿Me ayudas otra vez? Gracias.
¿Es decir se puede poner en la macro las respuestas por defecto a las preguntas? Las respuestas serían estas:
1.- Dando 2 columnas de la tabla esta macro reemplazar un rango del usuario --- aceptar
2.- seleccione 2 columnas de la tabla y el texto de reemplazo -- $V$2:$W$275
3.- seleccione el rango para reemplazar ----- $P:$Q
4.- digite 1 para coincidencia exacta, 2 para parcial ----- 2
5.- Continuar o retroceder --- Sí
Imagino que si se podrá, pero yo por más que lo he intentado no me acaba de salir. ¿Me ayudas otra vez? Gracias.
1 Respuesta
Respuesta de Juan Carlos González Chavarría
1
Aquí está con las modificaciones.
Sub MultiReemplazo()
Dim ColOne() As String, ColTwo() As String
Dim rngRange1 As Range, rngRange2 As Range
Dim intResponse As Integer
Dim intLookAt As Integer
Dim iCols As Long
Dim iRows As Long
Dim i As Long
On Error Resume Next
intResponse = MsgBox("Dando 2 Columnas de la Tabla" & vbCrLf & "Esta macro reemplazará un rango del usuario", vbExclamation + vbOKCancel, "Reemplazar")
If intResponse = vbOK Then
Set rngRange1 = Range("$V$2:$W$275")
If rngRange1 Is Nothing Then Exit Sub
DoEvents
Set rngRange2 = Range("$P:$Q")
If rngRange2 Is Nothing Then Exit Sub
iCols = rngRange1.Columns.Count
iRows = rngRange1.Rows.Count
If rngRange1.Columns.Count > 2 Or rngRange1.Columns.Count < 2 Then
MsgBox "You must select a two-column range of cells", vbCritical + vbOKOnly
Exit Sub
End If
On Error GoTo errorhandler
ReDim ColOne(1 To iRows)
ReDim ColTwo(1 To iRows)
For i = 1 To iRows
ColOne(i) = rngRange1.Cells(i, 1)
ColTwo(i) = rngRange1.Cells(i, 2)
Next i
If Err <> 0 Then
MsgBox Err.Number & " :" & Err.Description
On Error GoTo 0
Exit Sub
End If
DoOver:
intLookAt = 1
intResponse = MsgBox("Continuar(Si) o Retroceder(No)", vbQuestion + vbYesNoCancel, "Multi-Reemplazo")
If intResponse = vbCancel Then Exit Sub
If intResponse = vbYes Then
On Error GoTo errorhandler
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 1 To iRows
rngRange2.Replace What:=ColOne(i), Replacement:=ColTwo(i), LookAt:=intLookAt, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next i
End If
If intResponse = vbNo Then
For i = 1 To iRows
rngRange2.Replace What:=ColTwo(i), Replacement:=ColOne(i), LookAt:=intLookAt, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next i
End If
End If
Application.ScreenUpdating = True
MsgBox "Selección Reemplazada"
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
Exit Sub
errorhandler:
MsgBox "Error: " & Err.Number & " (" & Err.Description & ")"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub
[email protected]
Sub MultiReemplazo()
Dim ColOne() As String, ColTwo() As String
Dim rngRange1 As Range, rngRange2 As Range
Dim intResponse As Integer
Dim intLookAt As Integer
Dim iCols As Long
Dim iRows As Long
Dim i As Long
On Error Resume Next
intResponse = MsgBox("Dando 2 Columnas de la Tabla" & vbCrLf & "Esta macro reemplazará un rango del usuario", vbExclamation + vbOKCancel, "Reemplazar")
If intResponse = vbOK Then
Set rngRange1 = Range("$V$2:$W$275")
If rngRange1 Is Nothing Then Exit Sub
DoEvents
Set rngRange2 = Range("$P:$Q")
If rngRange2 Is Nothing Then Exit Sub
iCols = rngRange1.Columns.Count
iRows = rngRange1.Rows.Count
If rngRange1.Columns.Count > 2 Or rngRange1.Columns.Count < 2 Then
MsgBox "You must select a two-column range of cells", vbCritical + vbOKOnly
Exit Sub
End If
On Error GoTo errorhandler
ReDim ColOne(1 To iRows)
ReDim ColTwo(1 To iRows)
For i = 1 To iRows
ColOne(i) = rngRange1.Cells(i, 1)
ColTwo(i) = rngRange1.Cells(i, 2)
Next i
If Err <> 0 Then
MsgBox Err.Number & " :" & Err.Description
On Error GoTo 0
Exit Sub
End If
DoOver:
intLookAt = 1
intResponse = MsgBox("Continuar(Si) o Retroceder(No)", vbQuestion + vbYesNoCancel, "Multi-Reemplazo")
If intResponse = vbCancel Then Exit Sub
If intResponse = vbYes Then
On Error GoTo errorhandler
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 1 To iRows
rngRange2.Replace What:=ColOne(i), Replacement:=ColTwo(i), LookAt:=intLookAt, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next i
End If
If intResponse = vbNo Then
For i = 1 To iRows
rngRange2.Replace What:=ColTwo(i), Replacement:=ColOne(i), LookAt:=intLookAt, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next i
End If
End If
Application.ScreenUpdating = True
MsgBox "Selección Reemplazada"
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
Exit Sub
errorhandler:
MsgBox "Error: " & Err.Number & " (" & Err.Description & ")"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub
[email protected]
