copy column to row on new worksheet based on cell values in column A

[hwesterlaken]

i have a question,

i have an excel sheet with in column a names, i want to copy all values from the second column to another worksheet if the name does not change for the next row in the first column
if in the next row the name changes then a new row must be made with that name and the values from column b until the name changes again

test	training1	stad1
test	training2	stad1
test	training3	stad1
henk	training1	stad2
henk	training2	stad2
henk	training3	stad2
henk	training4	stad2
c	training1	stad1

the row on the new worksheet looks like the following
test training1 training 2 training3
henk training1 training2 training3 training 4
c training1

can this be done with vba

[p45cal]

If:

• you have headers for the above table and
• the table has no formulae in the 2nd column and
• the table starts in A1 and
• you have a clear Sheet2 and
• the active sheet is the sheet with the table on then

try:

Sub blah()
Set startrng = Range("A1").CurrentRegion
Range("A1").Subtotal GroupBy:=1, Function:=xlCount, TotalList:=Array(3), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
destRw = 0
For Each are In startrng.Offset(1).Columns(2).SpecialCells(xlCellTypeConstants, 23).Areas
  destRow = destRow + 1
  Sheets("Sheet2").Cells(destRow, 1).Value = are.Cells(1).Offset(, -1).Value
  Sheets("Sheet2").Cells(destRow, 2).Resize(, are.Rows.Count).Value = Application.Transpose(are.Value)
Next are
Range("A1").RemoveSubtotal
End Sub

[hwesterlaken]

many thanks

this works, i have a additional question, if i have more than 1 column aftrerthe name, for example 4 more how can i make it so that all columns get tot the other workbook and not only the training column

If:

• you have headers for the above table and
• the table has no formulae in the 2nd column and
• the table starts in A1 and
• you have a clear Sheet2 and
• the active sheet is the sheet with the table on then

try:

Sub blah()
Set startrng = Range("A1").CurrentRegion
Range("A1").Subtotal GroupBy:=1, Function:=xlCount, TotalList:=Array(3), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
destRw = 0
For Each are In startrng.Offset(1).Columns(2).SpecialCells(xlCellTypeConstants, 23).Areas
  destRow = destRow + 1
  Sheets("Sheet2").Cells(destRow, 1).Value = are.Cells(1).Offset(, -1).Value
  Sheets("Sheet2").Cells(destRow, 2).Resize(, are.Rows.Count).Value = Application.Transpose(are.Value)
Next are
Range("A1").RemoveSubtotal
End Sub

[p45cal]

How do you want the extra data to be placed in the new sheet?

[hwesterlaken]

Behind THE data wich already is in the row with the trainingen

How do you want the extra data to be placed in the new sheet?

[p45cal]

Behind THE data wich already is in the row with the trainingen

Don't understand.
In your first post in this thread you laid it out a bit with:
test training1 training 2 training3
henk training1 training2 training3 training 4
c training1

Do the same again but incude the stad data.

[hwesterlaken]

it should lookl like

test training1 training 2 training3 stad1
henk training1 training2 training3 training 4 stad2
c training1 stad1

Don't understand.
In your first post in this thread you laid it out a bit with:
test training1 training 2 training3
henk training1 training2 training3 training 4
c training1

Do the same again but incude the stad data.

[p45cal]

same provisos as before:

Sub blah2()
Dim colm As Range
Set startrng = Range("A1").CurrentRegion
Range("A1").Subtotal GroupBy:=1, Function:=xlCount, TotalList:=Array(3), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
destRow = 0
ColmsToTranferCount = startrng.Columns.Count - 1
For Each are In startrng.Offset(1).Columns(2).SpecialCells(xlCellTypeConstants, 23).Areas
  destRow = destRow + 1
  Sheets("Sheet2").Cells(destRow, 1).Value = are.Cells(1).Offset(, -1).Value
  DestColm = 2
  For Each colm In are.Resize(, ColmsToTranferCount).Columns
    sss = GetUniques(colm)
    Select Case True
      Case IsArray(sss)
        Sheets("Sheet2").Cells(destRow, DestColm).Resize(, UBound(sss) + 1).Value = sss  'Application.Transpose(colm.Value)
        DestColm = DestColm + UBound(sss) + 1
      Case IsEmpty(sss)
      Case Else
        Sheets("Sheet2").Cells(destRow, DestColm).Value = sss
        DestColm = DestColm + 1
    End Select
  Next colm
Next are
Range("A1").RemoveSubtotal
End Sub

Function GetUniques(rng As Range)
If Application.WorksheetFunction.CountBlank(rng) = rng.Cells.Count Then
  GetUniques = Empty
Else
  If rng.Cells.Count = 1 Then
    GetUniques = rng.Value
  Else
    Z = rng.Value
    Set myDictionary = CreateObject("Scripting.Dictionary")
    myDictionary.CompareMode = vbTextCompare  'case insensitive
    For Each itm In Z
    If Not IsEmpty(itm) Then If Not myDictionary.Exists(CStr(itm)) Then myDictionary.Add CStr(itm), itm
    Next itm
    GetUniques = myDictionary.Items
  End If
End If
End Function

[snb]

Alsjeblieft niet zinloos quoten.

Kun je je vraag niet beter op helpmij.nl plaatsen ?