دمج كل صفين معا دون فقد بيانات لعدد 160 صف

[بلانك]

دمج صفوف مثال.xlsx

[lionheart]

Sub Test()
    Dim m As Long, r As Long, n As Long
    Application.ScreenUpdating = False
        With ActiveSheet
            m = .Cells(Rows.Count, 1).End(xlUp).Row
            n = 1
            .Columns("K:M").WrapText = True
            For r = 1 To m Step 2
                .Range("K" & n).Resize(, 3).Value = Array(.Range("A" & r).Value & vbLf & .Range("A" & r + 1).Value, .Range("B" & r).Value & vbLf & .Range("B" & r + 1).Value, .Range("C" & r).Value & vbLf & .Range("C" & r + 1).Value)
                n = n + 1
            Next r
        End With
    Application.ScreenUpdating = True
End Sub

 

[بلانك]

شكرا جزيلا على الرد والكود وزادك الله علما ونفعا للاخرين واطمع في طلب بسيط تعديل الكود لدمج ثلاث صفوف وشكرا مقدما

[lionheart]

Use your mind please. Study the code well 

Think of dealing with the three rows by changing the step from step 2 to step 3 and change the code according this

[بلانك]

عملت الاتي ولم يفلح فأنا لست متخصص في الاكواد عذرا :

 

For r = 1 To m Step 3

[lionheart]

Try to get this line well

.Range("K" & n).Resize(, 3).Value = Array(.Range("A" & r).Value & vbLf & .Range("A" & r + 1).Value, .Range("B" & r).Value & vbLf & .Range("B" & r + 1).Value, .Range("C" & r).Value & vbLf & .Range("C" & r + 1).Value)

I didn't ask you to write a whole code, just understand the code to be able to modify it

[بلانك]

اشكرك على تعبك معي ولكن مازال الكود لايضم 3 صفوف وهذا هو الكود بعد التعديل :

 (  )Sub Test
    Dim m As Long, r As Long, n As Long
    Application.ScreenUpdating = False
        With ActiveSheet
            m = .Cells(Rows.Count, 1).End(xlUp).Row
            n = 1
            .Columns("K:M").WrapText = True
            For r = 1 To m Step 3
                .Range("K" & n).Resize(, 3).Value = Array(.Range("A" & r).Value & vbLf & .Range("A" & r + 1).Value, .Range("B" & r).Value & vbLf & .Range("B" & r + 1).Value, .Range("C" & r).Value & vbLf & .Range("C" & r + 1).Value)
                .Range("K" & n).Resize(, 3).Value = Array(.Range("A" & r).Value & vbLf & .Range("A" & r + 1).Value, .Range("B" & r).Value & vbLf & .Range("B" & r + 1).Value, .Range("C" & r).Value & vbLf & .Range("C" & r + 1).Value)
                n = n + 1
            Next r
        End With
    Application.ScreenUpdating = True
End Sub

 

دمج3 صفوف.xlsm

[lionheart]

That's great you have tried that's a great step towards learning

Sub Test()
    Dim m As Long, r As Long, n As Long
    Application.ScreenUpdating = False
        With ActiveSheet
            m = .Cells(Rows.Count, 1).End(xlUp).Row
            n = 1
            .Columns("K:M").WrapText = True
            For r = 1 To m Step 3
                .Range("K" & n).Resize(, 3).Value = Array(.Range("A" & r).Value & vbLf & .Range("A" & r + 1).Value & vbLf & .Range("A" & r + 2).Value, .Range("B" & r).Value & vbLf & .Range("B" & r + 1).Value & vbLf & .Range("B" & r + 2).Value, .Range("C" & r).Value & vbLf & .Range("C" & r + 1).Value & vbLf & .Range("C" & r + 2).Value)
                n = n + 1
            Next r
        End With
    Application.ScreenUpdating = True
End Sub

 

[بلانك]

احسنت  وزادك اله علما لتنفع به الاخرين امثالي