Help!

[florin1]

Hello! I need to transpose some data from columns to rows like in the example below using VBA. It seems simple but for me, a beginner, it is a little bit difficult.

A 3
B 2
B 8
A 6
B 1

to:

A 3 6
B 2 8 1

I really hope that someone can help me!

 

[florin1]

Hello,
Below you have the link. I've created a similar excel!
first run my_macro and after your_macro

https://app.box.com/s/60p8ipp1pfpnveepnfov

 

[hiker95]

florin1,

It is always best to display your actual raw data worksheet(s), and, the results that you are looking for. This way we can usually find a solution on the first go.

Thanks for the workbook.

Of course my macro does not work correctly with your new dataset. It was not designed to work with 6 columns.


What I need is another workbook, with your raw data in a worksheet with its original worksheet name.

And, in another worksheet what the results should look like (manually formatted by you for the results you are looking for).

 

[MARK858]

@Hiker95, I don't think the OP is dealing with the 6 columns in the "Data" sheet, it is the 2 columns in the "personal" sheet where column B is created by the OP's macro.

The problem is column A is a formula returning a text string which is messing up the sort.

If the OP changes their macro to add in the formula in column A and converts personal to values then it appears to work fine as is.

Apologies if you feel I'm out of order jumping in.

 

[florin1]

Hello again,
I've uploaded the file again and also information(see "info" sheet) of what I want to create.
The row data you can find in the "data" sheet. What I want to achieve after running the code you can find in the "personal" sheet.

I appreciate your help and interest!

https://app.box.com/s/60p8ipp1pfpnveepnfov

 

[MARK858]

Change the code in module2 to

Sub my_macro()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Workbooks("a").Activate

    Sheets("personal").UsedRange.Clear

    With Sheets("data")
        .Range("a2:a" & .Range("a" & Rows.Count).End(xlUp).Row).Copy
    End With

    With Sheets("personal")
        .Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                         :=False, Transpose:=False
        Application.CutCopyMode = False
        .Range("a1:a" & .Range("b" & Rows.Count).End(xlUp).Row).FormulaR1C1 = _
        "=IFERROR(INDEX(data!C[3],MATCH(personal!RC[1],data!C,0)),"""")"

        .Range("$B$1:$B$501").RemoveDuplicates Columns:=1, Header:=xlNo
        .UsedRange.Value = .UsedRange.Value
    End With

    your_macro

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Make sure that the sub "your_macro" is in the workbook then run "my_macro".

Assuming you still want it transposed as that isn't showing in your file.

 

[hiker95]

MARK858,

Thanks for you input.


florin1,

After your macro we have this (not all formulae in column A are shown for brevity):

Excel 2007
	A	B
1	CAD Electrical design	Blts, Jan
2	CAD Electrical design	Tippktter, Frank
3	CAD Electrical design	Pindak, Martin
4	CAD Electrical design	Jarmara, Martin
5	CAD Electrical design	Mammen Dr., Heinz-Theo
6	CAD Electrical design	Peng, Bruce
7	CAD Knowledge Based Engineering	Biermann Dr., Gerhard
8	CAD Knowledge Based Engineering	Kohlenberg, Petra
9	CAD Knowledge Based Engineering	Pott, Karl-Heinz
10	CAD Knowledge Based Engineering	Schrader-Mavridis, Marko
11	CAD Knowledge Based Engineering	Dolezel, Radek
12	CAD Knowledge Based Engineering	Sychrava, Petre
13
personal

Cell Formulas
Range	Formula
A1	=IFERROR(INDEX(data!D:D,MATCH(personal!B1,data!A:A,0)),"")

After my new macro we get this:

Excel 2007
	A	B
1	CAD Electrical design	Blts, Jan
2	CAD Electrical design	Tippktter, Frank
3	CAD Electrical design	Pindak, Martin
4	CAD Electrical design	Jarmara, Martin
5	CAD Electrical design	Mammen Dr., Heinz-Theo
6	CAD Electrical design	Peng, Bruce
7	CAD Knowledge Based Engineering	Biermann Dr., Gerhard
8	CAD Knowledge Based Engineering	Kohlenberg, Petra
9	CAD Knowledge Based Engineering	Pott, Karl-Heinz
10	CAD Knowledge Based Engineering	Schrader-Mavridis, Marko
11	CAD Knowledge Based Engineering	Dolezel, Radek
12	CAD Knowledge Based Engineering	Sychrava, Petre
13
personal

Cell Formulas
Range	Formula
A1	=IFERROR(INDEX(data!D:D,MATCH(personal!B1,data!A:A,0)),"")

And, this:

Excel 2007
	C	D	E	F	G	H	I	J
1		CAD Electrical design	Blts, Jan	Tippktter, Frank	Pindak, Martin	Jarmara, Martin	Mammen Dr., Heinz-Theo	Peng, Bruce
2		CAD Knowledge Based Engineering	Biermann Dr., Gerhard	Kohlenberg, Petra	Pott, Karl-Heinz	Schrader-Mavridis, Marko	Dolezel, Radek	Sychrava, Petre
3
personal

If the above is what you are looking for, then:

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).

Sub ReorgDataV2()
' hiker95, 05/25/2014, ME780017
Dim oa As Variant
Dim r As Long, lr As Long, nr As Long, nc As Long, n As Long
Application.ScreenUpdating = False
With Sheets("personal")
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  oa = .Range("A1:B" & lr)
  With .Range("A1:A" & lr)
    .Value = .Value
  End With
  .Range("A1:B" & lr).Sort key1:=Range("A1"), order1:=1
  nr = 0
  For r = 1 To lr
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    If n = 1 Then
      nr = nr + 1
      .Cells(nr, 4).Resize(, 2).Value = .Cells(r, 1).Resize(, 2).Value
    ElseIf n > 1 Then
      nr = nr + 1
      .Cells(nr, 4).Value = .Cells(r, 1).Value
      .Cells(nr, 5).Resize(, n).Value = Application.Transpose(.Range("B" & r & ":B" & r + n - 1).Value)
    End If
    r = r + n - 1
  Next r
  .Range("A1:B" & lr) = oa
  With .Range("A1:A" & lr)
    .Formula = "=IFERROR(INDEX(data!D:D,MATCH(personal!B1,data!A:A,0)),"""")"
  End With
  .Columns.AutoFit
  .Activate
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

Then run the ReorgDataV2 macro.

 

[hiker95]

MARK858,

Here is your new my_macro_V2 - it will add the formulae in worksheet personal column A.


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).

Sub my_macro_V2()
' hiker95, 05/25/2014, ME780017
Dim lr As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Workbooks("a").Activate
Sheets("data").Activate
Range("A2:A10000").Select
Selection.Copy
Sheets("personal").Activate
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Range("$B$1:$B$501").RemoveDuplicates Columns:=1, Header:=xlNo
lr = Cells(Rows.Count, 2).End(xlUp).Row
Range("A1:A" & lr).Formula = "=IFERROR(INDEX(data!D:D,MATCH(personal!B1,data!A:A,0)),"""")"
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

Then run the my_macro_V2 macro.

Then run the ReorgDataV2 macro.

 

[MARK858]

Thanks Hiker95 , I posted a version in post #15 (but I haven't checked your code yet to see if I missed anything).

I will have a read of your code tomorrow (well actually tonight looking at the clock ) to compare with mine as I am just knocking off for the night.

 

[hiker95]

MARK858,

I am sorry, my reply #17 was meant for florin1.

 

[MARK858]

No problem, have a good one