End data to column G

[makinmomb]

Look at what i have done manually

Shift data to next row , should not exceed column G

Data A1:M20

See sample expected to A22:G44

Macro to work at 44,444 rows

Note : Push data to next line starting column C if data extends column G

[sintek]

Sub J3v16()
Dim Data, Temp, i As Long, ii As Long, x As Long, xx As Long
With Cells(1).CurrentRegion
    Data = .Value
    ReDim Temp(1 To UBound(Data, 1) + UBound(Data, 2), 1 To 7)
    For i = 1 To UBound(Data, 1)
        x = x + 1: xx = 0
        For ii = 1 To UBound(Data, 2)
            If Data(i, ii) <> "" Then
                xx = xx + 1
                If xx = 8 Then x = x + 1: xx = 3
                Temp(x, xx) = Data(i, ii)
            End If
        Next ii
    Next i
    .ClearContents
    .Resize(x, 7) = Temp
End With
End Sub

[bebo021999]

Try:

Option Explicit 
Sub test() 
Dim lr&, i&, j&, r&, k&, c&, t&, rng, arr(1 To 10000, 1 To 7) 
rng = Range("A1").CurrentRegion.Value 
For i = 1 To UBound(rng) 
    r = t + 1 
    arr(r, 1) = rng(i, 1): arr(r, 2) = rng(i, 2) 
    For j = 3 To UBound(rng, 2) 
        If rng(i, j) <> "" Then 
            t = r + Int((j - 3) / 5) 
            c = ((j - 3) Mod 5) + 3 
            arr(t, c) = rng(i, j) 
        End If 
    Next 
Next 
Range("A1:ZZ100000").ClearContents 
Range("A1").Resize(r, 7).Value = arr 
End Sub  

[makinmomb]

Thank u sintek and bebo21999

Will ask for an add on the macro , at column H i need to to count na alpha

See manually plugged results

[sintek]

I don't understand how you got those results...Why is H14, H16, H17 blank?

If this below is actual result required...

Untitled.png

Then this amendment will work...

Sub J3v16()
Dim Data, Temp, i As Long, ii As Long, x As Long, xx As Long
With Cells(1).CurrentRegion
    Data = .Value
    ReDim Temp(1 To UBound(Data, 1) + UBound(Data, 2), 1 To 8)
    For i = 1 To UBound(Data, 1)
        x = x + 1: xx = 0
        For ii = 1 To UBound(Data, 2)
            If Data(i, ii) <> "" Then
                xx = xx + 1
                If xx = 8 Then x = x + 1: xx = 3
                Temp(x, xx) = Data(i, ii): Temp(x, 8) = xx - 2
            End If
        Next ii
    Next i
    .ClearContents
    .Resize(x, 8) = Temp
End With
End Sub

[makinmomb]

for AEINRST it is 5 + 5 + 1 that is 11

It should plug 11 at row 15 and leave blank at row 16 and 17

[jindon]

Sub test()
    Dim a, b, i As Long, ii As Long, temp As Long, n As Long, t As Long
    a = Sheets(1).Cells(1).CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) * (UBound(a, 2) - 3), 1 To 8)
    For i = 1 To UBound(a, 1)
        n = n + 1: temp = n
        For ii = 1 To 2
            b(n, ii) = a(i, ii)
        Next
        t = 3
        For ii = 3 To UBound(a, 2)
            If a(i, ii) = "" Then Exit For
            b(temp, 8) = b(temp, 8) + 1
            b(n, t) = a(i, ii)
            t = t + 1
            If t > 7 Then n = n + 1: t = 3
        Next
    Next
    Sheets.Add.Cells(1).Resize(n, 8) = b
End Sub

[makinmomb]

It is blank as AEINSTR is a set of 11 words 5 each on two rows and 1 additional

[makinmomb]

Jindon yours too does not do 11 for h16

[jindon]

No idea why you want it 9 instead 11, so I'm out.

[makinmomb]

Jindon

These are 11

ANESTRI ANTSIER NASTIER RATINES RESIANT
RETAINS RETINAS RETSINA STAINER STARNIE
STEARIN

[sintek]

Sub J3v16()
Dim Data, Temp, i As Long, ii As Long, x As Long, xx As Long, xxx As Long
With Cells(1).CurrentRegion
    Data = .Value
    ReDim Temp(1 To UBound(Data, 1) + UBound(Data, 2), 1 To 8)
    For i = 1 To UBound(Data, 1)
        x = x + 1: xx = 0: xxx = -2
        For ii = 1 To UBound(Data, 2)
            If Data(i, ii) <> "" Then
                xx = xx + 1: xxx = xxx + 1
                If xx = 8 Then x = x + 1: xx = 3
                Temp(x, xx) = Data(i, ii)
            End If
        Next ii
        Temp(x, 8) = xxx
    Next i
    .ClearContents
    .Resize(x, 8) = Temp
End With
End Sub

[jindon]

Sub test()
    Dim a, b, i As Long, ii As Long, temp As Long, n As Long, t As Long, x As Long
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) * (UBound(a, 2) - 3), 1 To 8)
    For i = 1 To UBound(a, 1)
        n = n + 1: temp = n
        For ii = 1 To 2
            b(n, ii) = a(i, ii)
        Next
        t = 3: x = 0
        For ii = 3 To UBound(a, 2)
            If a(i, ii) = "" Then Exit For
            x = x + 1
            b(n, t) = a(i, ii)
            t = t + 1
            If t > 7 Then n = n + 1: t = 3
        Next
        b(temp + Fix((n - temp) / 2), 8) = x
    Next
    Sheets.Add.Cells(1).Resize(n, 8) = b
End Sub

[makinmomb]

Run Time Error 9 on SIntek Macro on real data which is 44,000 rows
Jindon your macro is not working on 44,ooo rows and pours on results of test data given

[sintek]

Change red + to *

ReDim Temp(1 To UBound(Data, 1) + UBound(Data, 2), 1 To 8)

[makinmomb]

Sintex please paste code again so we can close thread , getting compile error

[jindon]

Tried 80000 rows with 30 cols data and no error.

Sub test()
    Dim a, b, i As Long, ii As Long, temp As Long, n As Long, t As Long, x As Long
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) * (UBound(a, 2) - 3), 1 To 8)
    For i = 1 To UBound(a, 1)
        n = n + 1: temp = n
        For ii = 1 To 2
            b(n, ii) = a(i, ii)
        Next
        t = 2: x = 0
        For ii = 3 To UBound(a, 2)
            If a(i, ii) = "" Then Exit For
            x = x + 1: t = t + 1
            If t > 7 Then n = n + 1: t = 3
            b(n, t) = a(i, ii)
        Next
        b(temp + Fix((n - temp) / 2), 8) = x
    Next
    Sheets("sheet2").Cells(1).Resize(n, 8) = b
End Sub

[makinmomb]

Find attached file with added details for upto 5oo rows to see if it works

[jindon]

DO NOT MIX MY CODE WITH OTHERS.

Sub test()
    Dim a, b, i As Long, ii As Long, temp As Long, n As Long, t As Long, x As Long
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) * (UBound(a, 2) - 3), 1 To 8)
    For i = 1 To UBound(a, 1)
        n = n + 1: temp = n
        For ii = 1 To 2
            b(n, ii) = a(i, ii)
        Next
        t = 2: x = 0
        For ii = 3 To UBound(a, 2)
            If a(i, ii) = "" Then Exit For
            x = x + 1: t = t + 1
            If t > 7 Then n = n + 1: t = 3
            b(n, t) = a(i, ii)
        Next
        b(temp + Fix((n - temp) / 2), 8) = x
    Next
    Sheets("sheet2").Cells(1).Resize(n, 8) = b
End Sub

[makinmomb]

Not working here are the results of the macro your jindon

Find attached

[sintek]

Have you tried mine? with that small change of + to *

[jindon]

Really hoepless...

[makinmomb]

Thank u Jindon bionic it pushed all that mass data at 1 second ,crazy

[makinmomb]

What is the meaning of binary macro , i have always saved files as Macro enabled , this binary thingi is my first time

[makinmomb]

Sintek yours working as quick as Jindon , button Jindon is faster by another 3 seconds as his got that run button

[makinmomb]

I have collected both versions including that of Sintek , it is as good as that of Jindon