Boa tarde!!

Por favor leia as regras os arquivos devem ser compactados!!
Nossas Regras
viewtopic.php?f=7&t=203
Att

Ola Alexandre

Desculpe-me

Segue o arquivo compactado

Att

Pessoal

Por favor sera que alguem pode me ajudar

Att

Bom dia!!

Faça uma adaptação

Sub EuOdeioCelulasMescladas()
    Dim myBefR As Integer, _
        myResR As Integer, _
        myCol  As Integer, _
        mybefrT As String, _
        myColT As String
    ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count)  'add sheet res
    Sheets(Worksheets.Count).Name = "Res"
    ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count)  'add sheet temp
    Sheets(Worksheets.Count).Name = "Temp"
'
    Sheets("Plan1").Select
    Range("A1:D1").Copy
    Sheets("Res").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("Plan1").Select
    myBefR = 2
    myResR = 2
    While Cells(myBefR, 3).Text <> ""
        Range("C" & myBefR).Copy
        Sheets("Temp").Select
        Range("A3").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
                    
        Selection.TextToColumns Destination:=Range("A3"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
            :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
            Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), TrailingMinusNumbers:=True
        myCol = Range("A3").End(xlToRight).Column
        If Range("B3") = "" And myCol = 256 Then myCol = 1
        Sheets("Plan1").Select
        mybefrT = myBefR
        Range("A" & mybefrT).Copy
        Sheets("Temp").Select
        Range("A1:J1").Select
        ActiveSheet.Paste
        
        Sheets("Plan1").Select
        Range("B" & myBefR).Copy
        Sheets("Temp").Select
        Range("A2:J2").Select
        ActiveSheet.Paste
        
        Sheets("Plan1").Select
        Range("D" & mybefrT).Copy
        Sheets("Temp").Select
        Range("A4:J4").Select
        ActiveSheet.Paste
        
        Range("A1:J4").Copy
        Sheets("Res").Select
        mybefrT = myResR
        Range("A" & mybefrT).Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        myResR = myResR + myCol
        myresrt = myResR
        Rows("" & myResR & ":" & (myResR + 10) & "").Select
        Application.CutCopyMode = False
        Selection.Delete Shift:=xlUp
        
        Sheets("Temp").Select
        Rows("1:4").Select
        Application.CutCopyMode = False
        Selection.Delete Shift:=xlUp
        
        myBefR = myBefR + 1
        Sheets("Plan1").Select
      
    Wend

    Sheets("Temp").Select
    ActiveWindow.SelectedSheets.Delete

End Sub

Alexandre

obrigado pela ajuda

a macro esta funcionando parcialmente...parece que ela se perde no meio da execucao
poderia por gentileza verificar

feliz ano novo

grato

Bom dia, de acordo com o que entedi criei a rotina, segue em anexo, favor comentar.

Att MarkoSoftware

MUITO OBRIGADO MARKO...PELA AJUDA....UM FELIZ ANO NOVO