VBA help

[sandejos]

Hi Friends,
Hi need small help from you. I have a data in column only but i need to bifurcate in different columns please see below example and help me how to write the code in VBA.
My Input Output Would be
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Column A[/TD]
[TD]Column B[/TD]
[TD]Column C[/TD]
[TD]Column D[/TD]
[TD]Column E[/TD]
[TD]Column E [/TD]
[/TR]
[TR]
[TD]Name[/TD]
[TD][/TD]
[TD]Name[/TD]
[TD]Contact 1[/TD]
[TD]Contact 2[/TD]
[TD]Designation[/TD]
[/TR]
[TR]
[TD]Contact 1[/TD]
[TD][/TD]
[TD]ABC[/TD]
[TD]9125392539[/TD]
[TD]9859233617[/TD]
[TD]Manager[/TD]
[/TR]
[TR]
[TD]Contact 2[/TD]
[TD][/TD]
[TD]CDE[/TD]
[TD]9125447721[/TD]
[TD]9921378251[/TD]
[TD]Sr Manager[/TD]
[/TR]
[TR]
[TD]Designation[/TD]
[TD][/TD]
[TD]GHI[/TD]
[TD]9723644574[/TD]
[TD]9423165959[/TD]
[TD]Director[/TD]
[/TR]
[TR]
[TD]ABC[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9125392539[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9859233617[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Manager[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]CDE[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9125447721[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9921378251[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Sr Manager[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]GHI[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9723644574[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9423165959[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Director[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Thanks,
Sandeep

 

[Roderick_E]

This example assumes:
1) Data on Sheet2, change as needed.
2) Data starts at A1

Sub bifurcator()
Dim rowloop As Long
Dim colloop As Long
rowloop = 2
colloop = 3
lastrow = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
For x = 1 To lastrow
'make column headers first
If x < 5 Then
Sheet2.Cells(1, x + 2) = Sheet2.Cells(x, 1)
End If
'move data to new columns
If x >= 5 Then
Sheet2.Cells(rowloop, colloop) = Sheet2.Cells(x, 1)
colloop = colloop + 1
If colloop > 6 Then
colloop = 3
rowloop = rowloop + 1
End If
End If
Next x
End Sub

 

[tonyyy]

Another approach...

Sub TransposeColumns()
Dim i As Long, j As Long, k As Long, Steps As Long
Dim arr() As Variant

On Error GoTo errHandler
arr = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Steps = InputBox(prompt:="Number of rows to transpose in steps:", Default:=4)
j = 1
k = 1
For i = LBound(arr, 1) To UBound(arr, 1)
    For j = 3 To 3 + Steps - 1
        Cells(k, j) = arr(i, 1)
        i = i + 1
    Next j
    i = i - 1
    k = k + 1
Next i
errHandler:
    If Err.Number <> 0 Then Debug.Print Err.Number & ", " & Err.Description
    Columns.AutoFit
End Sub

Cheers,

tonyyy

 

[hiker95]

sandejos,

Here is another macro solution for you to consider, that uses two arrays in memory, and, will adjust to the number of raw data rows, and, should be very fast.

You can change the raw data worksheet name in the macro.

Sample raw data, and, results:

Excel 2007
	A	B	C	D	E	F
1	Name		Name	Contact 1	Contact 2	Designation
2	Contact 1		ABC	9125392539	9859233617	Manager
3	Contact 2		CDE	9125447721	9921378251	Sr Manager
4	Designation		GHI	9723644574	9423165959	Director
5	ABC
6	9125392539
7	9859233617
8	Manager
9	CDE
10	9125447721
11	9921378251
12	Sr Manager
13	GHI
14	9723644574
15	9423165959
16	Director
17
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ReorgData()
' hiker95, 01/17/2017, ME986085
Dim a As Variant, i As Long, lr As Long, nlr As Long
Dim o As Variant, j As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")   '<-- you can change the sheet name here
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  nlr = Application.Ceiling(lr, 4)
  a = .Range("A1:A" & nlr)
  ReDim o(1 To (nlr / 4), 1 To 4)
  For i = 1 To UBound(a, 1) Step 4
    j = j + 1
    o(j, 1) = a(i, 1): o(j, 2) = a(i + 1, 1): o(j, 3) = a(i + 2, 1): o(j, 4) = a(i + 3, 1)
  Next i
  .Cells(1, 3).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(3).Resize(, 4).AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgData macro.

 

[sandejos]

Thank you very much It works perfectly

 

[sandejos]

Thanks above code working fine

 

[hiker95]

Re: VBA help
Thank you very much It works perfectly

Re: VBA help
Thanks above code working fine

sandejos,

Thanks for the feedback.

You are very welcome. Glad we could help.

And, come back anytime.

 

[tonyyy]

You're welcome. Glad it worked out...