• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Hulp gevraagd: rijen in werkblad transponeren met macro

Status
Niet open voor verdere reacties.
Z

ZiggyFartdust

Gebruiker
Lid geworden
2 mrt 2018
Berichten
15
Hi, eerste post op dit forum...... Ik heb een vraag over MS Excel (2016 NL) waar iemand mij hopelijk mee kan helpen.

Ik heb een Excel-werkblad met 1 tabblad met 16 kolommen, A t/m P, en een n-aantal rijen (ik schrijf hier ‘n’ omdat het aantal rijen momenteel nog wordt aangevuld - als het voor de macro handig is kan hier ook een vaste waarde voor worden genomen, bijvoorbeeld 50). De eerste rij bevat de kolomkoppen en de rijen eronder de data.

Wat ik zou willen bereiken:
1) dat rij 1 met de kolomkoppen EN elke unieke rij data naar een nieuw tabblad wordt gekopieerd, dus dan zou je op tabblad 2 rij 1 en rij 2 krijgen, op tabblad 3 rij 1 en rij 3, op tabblad 4 rij 1 en rij 4, enzovoort.
2) dat de gekopieerde gegevens vervolgens ook worden getransponeerd, dus zodat rij 1 (de kolomkoppen) onder elkaar worden gezet in kolom A en de data-rij ernaast in kolom B

Is het mogelijk om dit met een macro voor elkaar te krijgen? De macro zou dan moeten lopen tot de laatste data-rij op tabblad 1. Ik heb een testbestandje bijgevoegd (Bekijk bijlage test.xlsx).

Bij voorbaat dank voor de hulp!
 
Hallo en welkom op dit forum,

Dat zou hiermee kunnen:

Code: 
Sub Macro1()
    Range("A1").CurrentRegion.Copy
    Sheets("Blad2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub

Succes!
 
Succes.

Code: 
Sub hsv()
Dim sv, dic As Object, i As Long, ii As Long
With Sheets("Blad1")
sv = .Cells(1).CurrentRegion
Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(sv)
      dic.Item(sv(i, 1)) = ""
    Next i
 For ii = 0 To dic.Count - 1
   With .Cells(1).CurrentRegion
      .AutoFilter 1, dic.Keys()(ii)
      If IsError(Evaluate(dic.Keys()(ii) & "!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = dic.Keys()(ii)
      .Copy Sheets(dic.Keys()(ii)).Cells(1)
      .AutoFilter
    End With
  Next ii
 End With
End Sub
 
JanBG zei:
Hallo en welkom op dit forum,

Dat zou hiermee kunnen:

Code: 
Sub Macro1()
    Range("A1").CurrentRegion.Copy
    Sheets("Blad2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub

Succes!
Klik om te vergroten...

Bedankt voor het meedenken JanBG!

Je macro werkt, maar doet niet helemaal wat ik voor ogen heb. Het resultaat is nu dat Blad1 onaangetast blijft (dat is prima), maar dat alle info op Blad2 wordt geplaatst. Kolom A op Blad2 bevat nu alle kolomkoppen (dat is ook prima) en kolom B tot en met n bevatten de data. Wat ik voor ogen heb, is dat Blad2 Kolom A+B bevat, Blad3 Kolom A+C, Blad4 Kolom A+D enzovoort. Zou dat mogelijk zijn?
 
HSV zei:
Succes.

Code: 
Sub hsv()
Dim sv, dic As Object, i As Long, ii As Long
With Sheets("Blad1")
sv = .Cells(1).CurrentRegion
Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(sv)
      dic.Item(sv(i, 1)) = ""
    Next i
 For ii = 0 To dic.Count - 1
   With .Cells(1).CurrentRegion
      .AutoFilter 1, dic.Keys()(ii)
      If IsError(Evaluate(dic.Keys()(ii) & "!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = dic.Keys()(ii)
      .Copy Sheets(dic.Keys()(ii)).Cells(1)
      .AutoFilter
    End With
  Next ii
 End With
End Sub
Klik om te vergroten...

Bedankt Harry. Wanneer ik je macro uitvoer krijg ik een foutmelding. hsv-macro-foutmelding.jpg
 
paar quotes maar
Code: 
 If IsError(Evaluate([COLOR=#0000ff]"'" & dic.Keys()(ii) & "'!A1"[/COLOR])) Then Sheets.Add(, Sheets(Sheets.Count)).Name = dic.Keys()(ii)
 
Staan er spaties in cellen die leeg lijken?
 
In je bijlage staat het duidelijk dat die tekens niet mogen in de naam van een blad.

Het moet ook transpose?
Code: 
Sub hsv()
Dim sv, arr, dic As Object, i As Long, ii As Long
With Sheets("Blad1")
sv = .Cells(1).CurrentRegion
Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(sv)
      dic.Item(sv(i, 1)) = ""
    Next i
 For ii = 0 To dic.Count - 1
   With .Cells(1).CurrentRegion
      .AutoFilter 1, dic.Keys()(ii)
      If IsError(Evaluate("'" & dic.Keys()(ii) & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = dic.Keys()(ii)
        Sheets(dic.Keys()(ii)).Cells(1).CurrentRegion.Clear
        .Copy Sheets(dic.Keys()(ii)).Cells(1)
         arr = Sheets(dic.Keys()(ii)).Cells(1).CurrentRegion
         Sheets(dic.Keys()(ii)).Cells(1).CurrentRegion.Clear
         Sheets(dic.Keys()(ii)).Cells(1).Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)
        .AutoFilter
    End With
  Next ii
 End With
End Sub

Mag ook zo.
Code: 
Sub hsv()
Dim sv, arr, arr2, dic As Object, i As Long, ii As Long
With Sheets("Blad1")
sv = .Cells(1).CurrentRegion
Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(sv)
      dic.Item(sv(i, 1)) = ""
    Next i
 For ii = 0 To dic.Count - 1
   With .Cells(1).CurrentRegion
      .AutoFilter 1, dic.Keys()(ii)
      If IsError(Evaluate("'" & dic.Keys()(ii) & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = dic.Keys()(ii)
        Sheets(dic.Keys()(ii)).Cells(1).CurrentRegion.Clear
         arr = Sheets("blad1").AutoFilter.Range.Offset(1).SpecialCells(12, 2)
         arr2 = .Rows(1)
         Sheets(dic.Keys()(ii)).Cells(1).Resize(UBound(arr, 2)) = application.transpose(arr2)
         Sheets(dic.Keys()(ii)).Cells(1, 2).Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)
        .AutoFilter
    End With
  Next ii
 End With
End Sub
 
Laatst bewerkt:
Ik denk dat ik het toch anders ga aanpakken. Ik zal daarvoor een nieuwe thread openen om verwarring te voorkomen. Bedankt voor alle input zover!
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan