Juntar dos Macros

Buen dia,

Estimados tengo dos macros que utilizo diariamente en una lista de clientes y teléfonos.

* La primera Macro hace lo siguiente:

Tengo 2 filas, fila A con los CLIENTES y fila B con los teléfonos EJM

A B

CLIENTE 1 14584545

CLIENTE 1 14578454

CLIENTE 2 998787722

CLIENTE 2 44554488

CLIENTE 2 12345685

CLIENTE 3 14587575

CLIENTE 3 987565687

La macro lo que hace es escoger al primer cliente de la columna "A" y lo copia a la columna "D", ademas coloca los teléfonos de ese cliente en las columnas que le siguen:

EJM-1:

A B C D E F G
CLIENTE 1 14584545 CLIENTE 1 14584545 14578454
CLIENTE 1 14578454
CLIENTE 2 998787722 CLIENTE 2 998787722 44554488 12345685
CLIENTE 2 44554488
CLIENTE 2 12345685
CLIENTE 3 14587575 CLIENTE 3 14587575 987565687
CLIENTE 3 987565687

* La segunda macro:

separa los teléfonos FIJOS de CELULARES, (Celulares son los que comienzan con numero 9 y fijo todos los demás)

EJM-2

A B C D
CLIENTE 1 14584545 14578454
CLIENTE 2 44554488 12345685 998787722
CLIENTE 3 14587575 987565687

Lo que necesito es que primero se ejecute la MACRO 1, al finalizar que elimine las columnas "A"; "B"; y "C" del EJM-1, después esas filas vacías entre los clientes que se eliminen o en todo caso que se ordenen para que no quede ninguna fila en blanco.

Luego quedaría separar los teléfonos FIJOS de CELULARES que es la MACRO 2

NOTA: la Macro 2 separa los teléfonos pero comienza a buscar los teléfonos desde la columna C, eso también se debería cambiar para que busque desde la columna B.

dejo las macros; si se necesitan los ficheros los puedo enviar.

MACRO1

Sub prueba()
Range("a1").Select
Dim i As Integer
Do
i = ActiveCell.Row
buscando = ActiveCell.Value
fila = ActiveCell.Row
If Range("d:d").Find(buscando) Is Nothing Then
Range("D" & fila).Value = buscando
Range("D" & fila).Offset(0, 1).Value = ActiveCell.Offset(0, 1).Value
Else
fila2 = Range("d:d").Find(buscando).Row
If Range(Range("d" & fila2), Range("d" & fila2).End(xlToRight)).Find(ActiveCell.Offset(0, 1).Value) Is Nothing Then
Range("d:d").Find(buscando).End(xlToRight).Offset(0, 1).Value = ActiveCell.Offset(0, 1).Value
End If
End If
i = i + 1
Range("a" & i).Select
Loop While ActiveCell.Value <> ""
End Sub

MACRO2

Sub Ordenar_Telefonos()
Dim i, j, Ufila, Ucol, Locales, MaxLoc, Fijos, MaxFijos As Integer
Dim LugarLoc1, LugarFijo1, LocActual, FijoActual As Integer
Application.ScreenUpdating = False
Ucol = ActiveCell.SpecialCells(xlLastCell).Column
Ufila = Range("A" & Rows.Count).End(xlUp).Row
Set h1 = ActiveSheet
Sheets.Add
Set h2 = ActiveSheet
h1.Select
MaxLoc = 0: MaxFijos = 0
For i = 2 To Ufila
Locales = 0: Fijos = 0
For j = 3 To Ucol
If Cells(i, j) <> "" Then
If Left(Cells(i, j), 1) = 9 Then
Fijos = Fijos + 1
Else
Locales = Locales + 1
End If
End If
Next
If Fijos > MaxFijos Then MaxFijos = Fijos
If Locales > MaxLoc Then MaxLoc = Locales
Next
LugarLoc1 = 3
LugarFijo1 = MaxLoc + 3
For i = 1 To MaxLoc
Cells(1, LugarLoc1 + i - 1) = "CEL" & i
Next
For i = 1 To MaxFijos
Cells(1, LugarFijo1 + i - 1) = "FIJO" & i
Next
For i = 2 To Ufila
LocActual = LugarLoc1
FijoActual = LugarFijo1
For j = 3 To Ucol
If Left(Cells(i, j), 1) <> "" Then
If Left(h1.Cells(i, j), 1) <> 9 Then
h2.Cells(i, LocActual) = h1.Cells(i, j)
LocActual = LocActual + 1
Else
h2.Cells(i, FijoActual) = h1.Cells(i, j)
FijoActual = FijoActual + 1
End If
End If
Next
Next
h2.Select
h2.Range(Cells(2, "C"), Cells(Ufila, 2 + MaxLoc + MaxFijos)).Copy h1.Range("C2")
Application.DisplayAlerts = False
h2.Delete
Application.DisplayAlerts = True
h1.Select
Application.ScreenUpdating = True
MsgBox "Ordenar Teléfonos Fijos y Celulares. " & vbCr & _
"Proceso Terminado", vbInformation, "ORDENAR"
End Sub

1 Respuesta

Respuesta
1

Deja tus 2 macros sin cambios.
Agrega la siguiente macro en el mismo módulo donde tienes las 2 macros
Esta macro ejecuta las 2 macros y hace lo último que pides.

Sub une()
'por.DAM
'llama a la macro prueba
prueba
'llama a la macro Ordenar_Telefonos
Ordenar_Telefonos
Columns("A:B").Delete shift:=xlToLeft
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    Rows(i).SpecialCells(xlCellTypeBlanks).Delete shift:=xlToLeft
Next
End Sub

Prueba y me comentas

Saludos. DAM
Si es lo que necesitas.

Hola Dam,

Si me sirvió para unir las dos macros, pero lo que me falta es eliminar las filas que están vacías.

Sub une()
'por.DAM
'llama a la macro prueba
prueba
Columns("A:C").Delete Shift:=xlToLeft
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Rows(i).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
'llama a la macro Ordenar_Telefonos
Ordenar_Telefonos
Next
End Sub

hice unos pequeños cambios a eso le puedes agregar lo que mencione de eliminar las filas vacías por favor

Hola Dam,

Esta es la macro que me enviase; ahora para que desaparezcan las filas en blanco estoy ordenándolo de modo ascendente, pero lo que me faltaría añadír es que la macro no trabaje solo sobre la HOJA 1, sino quiero que trabaje sobre la hoja actual en la que trabajo, sea cual sea el nombre que tenga porque esta macro lo utilizo para hojas de distintos nombres y libros distintos.

Sub une()
'por.DAM
'llama a la macro prueba
prueba
Columns("A:C").Delete shift:=xlToLeft
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Rows(i).SpecialCells(xlCellTypeBlanks).Delete shift:=xlToLeft
Next
'Agrega columna B para adaptarse a la macro Ordenar_Telefonos
Columns("B:B").Insert shift:=xlToRight
'llama a la macro Ordenar_Telefonos
Ordenar_Telefonos
'Elimina columna B que se agrego
Columns("B:B").Delete shift:=xlToRight
'Ordena de menor a mayor los DNI
Cells.Select
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Hoja1").Sort
.SetRange Range("A1:AA65536")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

Perdona, pero no entendí al principio lo de eliminar los espacios en blanco. Pero que bueno que ya lo solucionaste.
Prueba con esta macro para que trabaje con cualquier hoja.

Sub une()
'por.DAM
'llama a la macro prueba
prueba
Columns("A:C").Delete shift:=xlToLeft
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    Rows(i).SpecialCells(xlCellTypeBlanks).Delete shift:=xlToLeft
Next
'Agrega columna B para adaptarse a la macro Ordenar_Telefonos
Columns("B:B").Insert shift:=xlToRight
'llama a la macro Ordenar_Telefonos
Ordenar_Telefonos
'Elimina columna B que se agrego
Columns("B:B").Delete shift:=xlToRight
'Ordena de menor a mayor los DNI
Cells.Select
ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.ActiveSheet.Sort
    .SetRange Range("A1:AA65536")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End Sub

Saludos.DAM
Si es lo que necesitas.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

¿Cómo combino dos macros que hacen lo que necesito?

Tengo que aplicar dos macros a muchos archivos en excel, Pero es laborioso estar haciendo manualmente algunos procesos para las macros. ¿Cómo fusiono estas dos macros? ¿Se requiere de hacer una nueva macro? Me refiero a las macros de las dos...
1 respuesta

Como unir varias macros en una sola

Tengo varias macros y deseo unirlas todas en una sola para ejecutarla en 100 archivos abiertos por ejemplo tengo una macro que me cambia parámetros tengo otra que borra la ultima linea de la hoja que tiene un parámetro ref tengo otra qu copia y pega...
1 respuesta

Macro para buscar valor "#N/A" en una columna

Me podrían ayudar con esta macro, Tengo una macro que me genera un reporte de inventario en un archivo excel, el archivo tiene códigos y formulas para la descripción de cada código, Ejemplo. Código descripción 001 zanahorias. 002 cebollas. 003...
1 respuesta