macro ter voorbereiding draaitabel

[sickofitall]

Hallo

in Bijlage staan op Blad 1 de gegevens.
Nu wil ik die anders ordenen, zoals op Blad 2, maw ik wil mijn gegevens converteren zodat ik ze later makkelijker kan gebruiken in een draaitabel.

Nu heb ik op dit forum reeds een convert-macro gevonden, maar ik snap er niet veel van om hem te veranderen naar de macro die ik nodig heb.
De macro in kwestie (van een zekere eenreus) is:

Sub convert()
Dim rS As Long
Dim cS As Long
Dim rT As Long

Application.ScreenUpdating = False
rS = 2
cS = 2
rT = 10

Do Until IsEmpty(Cells(rS, cS).Value)
    Do Until IsEmpty(Cells(rS, cS).Value)
    Cells(rT, 5).Value = Cells(1, cS).Value
    Cells(rT, 6).Value = Cells(rS, 1).Value
    Cells(rT, 7).Value = Cells(rS, cS).Value
    rS = rS + 1
    rT = rT + 1
    Loop
rS = 2
cS = cS + 1
Loop

Application.ScreenUpdating = True

End Sub

De macro is ook toegevoegd in de bijlage.

Ter aanvulling: Er kunnen kolommen en rijen toegevoegd worden dus de macro zou daar rekening mee moeten houden

Alvast bedankt!

 

[eenreus]

zoiets

Sub convert_2()

Dim rS As Long 'source
Dim cS As Long 'source
Dim rT As Long  'target
Dim Target As String
Dim Source As String


Application.ScreenUpdating = False
Source = ActiveSheet.Name

Worksheets.Add
Target = ActiveSheet.Name

'Header maken
Worksheets(Target).Cells(1, 1).Value = "maand"
Worksheets(Target).Cells(1, 2).Value = "cel"
Worksheets(Target).Cells(1, 3).Value = "waarde"


rS = 2
cS = 2

rT = 2


'Courier maken
Do Until IsEmpty(Worksheets(Source).Cells(rS, 1).Value)
    Worksheets(Target).Cells(rT, 1).Value = Worksheets(Source).Cells(rS, 1).Value
    Worksheets(Target).Cells(rT, 2).Value = "Courier"
    Worksheets(Target).Cells(rT, 3).Value = Worksheets(Source).Cells(rS, 2).Value
rT = rT + 1
rS = rS + 1
Loop
        
rS = 2
cS = 2
'Telefoon
Do Until IsEmpty(Worksheets(Source).Cells(rS, 1).Value)
    Worksheets(Target).Cells(rT, 1).Value = Worksheets(Source).Cells(rS, 1).Value
    Worksheets(Target).Cells(rT, 2).Value = "Telefoon"
    Worksheets(Target).Cells(rT, 3).Value = Worksheets(Source).Cells(rS, 3).Value
rT = rT + 1
rS = rS + 1
Loop
    



Application.ScreenUpdating = True

End Sub

 

[sickofitall]

alvast bedankt voor de moeite!!!

maar nu maakt hij enkel telefoon en courrier.
In feite zou de macro alle kolommen van de source moeten converteren.

Nu heb je per kolom (dus voor telefoon en courrier) apart een stukje in je macro heb ik gezien. Kun je deze stukken niet variabel maken zodat de macro verwijst naar de titel van de kolom (dus de waarde in rij 1)?
En dan de macro zodanig maken dat hij blijft lopen tot hij een lege kolom tegenkomt.

Dus samengevat loopt de macro tot hij een lege rij vindt, daarna neemt hij de volgende kolom opnieuw tot hij een lege rij vindt en ga zo maar door, tot hij een lege kolom tegenkomt. (of totdat de waarde van de volgende kolom in rij 1 leeg is).

Bedankt voor de moeite!!!

 

[eenreus]

zoiets?

Sub convert_3()

Dim rS As Long 'source
Dim cS As Long 'source
Dim rT As Long  'target
Dim Target As String
Dim Source As String


Application.ScreenUpdating = False
Source = ActiveSheet.Name

Worksheets.Add
Target = ActiveSheet.Name

'Header maken
Worksheets(Target).Cells(1, 1).Value = "maand"
Worksheets(Target).Cells(1, 2).Value = "cel"
Worksheets(Target).Cells(1, 3).Value = "waarde"


rS = 2
cS = 2

rT = 2



Do Until IsEmpty(Worksheets(Source).Cells(1, cS).Value)
    
    Do Until IsEmpty(Worksheets(Source).Cells(rS, 1).Value)
        Worksheets(Target).Cells(rT, 1).Value = Worksheets(Source).Cells(rS, 1).Value
        Worksheets(Target).Cells(rT, 2).Value = Worksheets(Source).Cells(1, cS).Value
        Worksheets(Target).Cells(rT, 3).Value = Worksheets(Source).Cells(rS, 2).Value
    rT = rT + 1
    rS = rS + 1
    Loop
rS = 2
cS = cS + 1
Loop
    
Application.ScreenUpdating = True

End Sub

 

[sickofitall]

Ideaal!

Das precies wat ik zocht!

Hartelijk bedankt!

 

[sickofitall]

Blijkbaar werkt de macro niet in een ander bestand

Ik heb de macro laten lopen en ik krijg wel alle juiste waarden van rij 1, alleen kopieert de macro steeds de waarden van kolom 2 ipv de bijbehorende kolom.

Wat loopt er fout?

 

[eenreus]

Tja een typ foutje


Worksheets(Target).Cells(rT, 3).Value = Worksheets(Source).Cells(rS, 2).Value

moet zijn

Worksheets(Target).Cells(rT, 3).Value = Worksheets(Source).Cells(rS, cS).Value

excuus

 

[sickofitall]

werkt prima!

thanks!

 

[sickofitall]

Ik heb ondertussen nog iets veel gemakkelijkers gevonden.

Zonder macro:
http://www.datapigtechnologies.com/flashfiles/Transposetables.html


:thumb:
:shocked:

 

[eenreus]

dank

Tnx...weer wat geleerd