JSDJSD

La forma del botón color y texto de la figura seleccionada según tu gusto

Otra opción la que te comenta el Maestro Antoni

Aquí tienes el archivo, prueba y comenta Organización Formaciones Centro (1 opcion).xlsm

De todos modos te dejo una opción que creo será mucho más cómoda para ti. Observa que en la barra ribbon tienes una nueva pestaña llamada Consolidar hojas en la que tienes un botón llamador Actualizar, simplemente púlsalo y se ejecuta la macro independientemente en la hoja que te encuentres. Si la hoja existe la actualiza y si no existe te la crea.

Esto ya lo hace la macro, no hay que modificarle nada

Sin ningún tipo de problema

Tal cual tienes el archivo subido tiene que funcionar si o si, simplemente darle un click sobre el botón

Sin tu archivo no es posible ayudarte

Sub ConsolidarSeguimientos(): Application.ScreenUpdating = False primeraCopia = True On Error Resume Next Set destino = Sheets("Seguimiento_Anual") If destino Is Nothing Then Set destino = Sheets.Add destino.Name = "Seguimiento_Anual" Else destino.Cells.Clear End If On Error GoTo 0 For Each ws In ThisWorkbook.Worksheets If ws.Name Like "Seguimiento_*" And ws.Name <> "Seguimiento_Anual" Then If Application.WorksheetFunction.CountA(destino.Cells) = 0 Then ultimaFila = 1 Else ultimaFila = destino.Cells(destino.Rows.Count, "A").End(xlUp).Row + 1 End If If primeraCopia Then ws.UsedRange.Copy Destination:=destino.Cells(ultimaFila, 1) primeraCopia = False Else ws.UsedRange.Offset(1, 0).Resize(ws.UsedRange.Rows.Count - 1).Copy _ Destination:=destino.Cells(ultimaFila, 1) End If End If Next ws ultimaFila = destino.Cells(destino.Rows.Count, "A").End(xlUp).Row Dim i As Long For i = ultimaFila To 2 Step -1 If IsEmpty(destino.Cells(i, 3)) Then destino.Rows(i).Delete End If Next i With destino.Sort .SortFields.Clear .SortFields.Add Key:=destino.Range("A2:A" & ultimaFila), Order:=xlAscending .SortFields.Add Key:=destino.Range("B2:B" & ultimaFila), Order:=xlAscending .SetRange destino.Range("A1").CurrentRegion .Header = xlYes .Apply End With destino.UsedRange.Columns.AutoFit MsgBox "Consolidación completada.", vbInformation End Sub Organización Formaciones Centro (1).xlsm

A ver si es esto lo que necesitas

Me alegro

Cambia tu macro5 por esta modificada y comenta Sub Paso5() Dim ws As Worksheet Dim tbl As ListObject Dim celda As Range Dim colIndex As Integer Dim lastRow As Long Dim currentRow As Long ' Seleccionar la hoja llamada "Consulta1" Set ws = ThisWorkbook.Sheets("Consulta1") ' Establecer la tabla "Consulta1" Set tbl = ws.ListObjects("Consulta1") ' Recorrer todas las celdas en el rango de datos de la tabla For Each celda In tbl.DataBodyRange ' Verificar si la celda contiene el texto "Cantidad Pedida" If celda.Value = "Cantidad Vendida" Then colIndex = celda.Column currentRow = celda.Row + 1 ' Mover el contenido de las celdas debajo de "Cantidad Pedida" a la segunda columna de la misma fila Do While ws.Cells(currentRow, colIndex).Value <> "" Or ws.Cells(currentRow, 1).Value <> "" ws.Cells(currentRow, 2).Value = ws.Cells(currentRow, colIndex).Value ws.Cells(currentRow, colIndex).ClearContents currentRow = currentRow + 1 Loop End If Next celda MsgBox "Las celdas debajo de 'Cantidad Pedida' han sido trasladadas a la segunda columna." End Sub

Pon un ejemplo de lo que quieres

A mi me pasó lo mismo, no lo entendí

Perfecto

Abre un nuevo tema y lo miramos

Perfecto, me alegro

En cuanto pueda te lo miro

Sub CombinarCeldaCyD(): Application.DisplayAlerts = False If Selection Is Nothing Then Exit Sub Set Celda = Selection If Celda.Column <> 3 Then Exit Sub TextoC = Celda.Value TextoD = Celda.Offset(0, 1).Value TextoCombinado = TextoC & " " & TextoD Set RangoACombinar = Range(Celda, Celda.Offset(0, 1)) With RangoACombinar .Merge .Value = TextoCombinado End With End Sub

El archivo Combinar celdas seleccionadas.xlsm

Prueba y comenta

Pues entonces, prueba y comenta Extraer nombre de carpetas y subcarpetas1.xlsm

Sería esto lo que necesitas ?

A ver si ahora triunfamos ¡¡