PDA

View Full Version : copy column to row on new worksheet based on cell values in column A



hwesterlaken
09-23-2015, 12:06 PM
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
09-23-2015, 01:56 PM
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
09-23-2015, 10:38 PM
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
09-24-2015, 02:15 AM
How do you want the extra data to be placed in the new sheet?

hwesterlaken
09-24-2015, 09:12 AM
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
09-24-2015, 09:30 AM
Behind THE data wich already is in the row with the trainingenDon'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
09-24-2015, 11:32 AM
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
09-24-2015, 01:52 PM
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
09-24-2015, 02:30 PM
Alsjeblieft niet zinloos quoten.

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