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

Rijen op eerste tabblad van werkblad kopieren naar nieuw tabblad en transponeren

Status
Niet open voor verdere reacties.
Z

ZiggyFartdust

Gebruiker
Lid geworden
2 mrt 2018
Berichten
15
Hi, tweede topic dat ik open 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). Zie bijlage voor een voorbeeld of om je macro uit te proberen.Bekijk bijlage Untitled form (Responses).xlsm

Wat ik zou willen bereiken:
1) dat tabblad 1 ongewijzigd blijft
2) dat elke rij één voor één naar een eigen nieuw tabblad in hetzelfde werkblad wordt gekopieerd (dus rij 1 van tabblad 1 naar tabblad 2, rij 2 van tabblad 1 naar tabblad 3, enzovoort – het aantal tabbladen is uiteindelijk gelijk aan het aantal rijen plus 1)
3) dat de gekopieerde gegevens vervolgens ook worden getransponeerd
4) dat elk nieuw tabblad een naam krijgt op basis van de getransponeerde celwaarden op datzelfde tabblad (een combinatie van cel A4 en A5)

N.B. 1 Stap 4 is geen noodzaak, maar meer een ‘nice to have’. Dus laat dat gerust buiten beschouwing als dat te lastig is.
N.B. 2 Wat problematisch kan zijn voor de macro: het eerste tabblad heet niet Blad1, maar Untitled Form (Responses) want het is input van een Google Formulier.

Is het mogelijk om dit met een macro voor elkaar te krijgen?

Bij voorbaat dank voor de hulp!
 
Laatst bewerkt:
En wat is er makkelijkere aan? Dat iemand anders het wiel opnieuw kan gaan uitvinden? Wijzig de code van @HSV in het andere draadje alles staat erin om ook aan deze vraag te voldoen. (Er staat dan zelfs teveel in om aan deze vraag te voldoen wat het nog makkelijker maakt om de code aan te passen)
 
Hierbij filter ik op dag.
Code: 
Sub hsv()
Dim sv, sv2, arr, i As Long, j As Long, c00 As String
With Sheets("form responses 1")
sv = .Cells(1).CurrentRegion
    For i = 2 To UBound(sv)
     If InStr(c00, Day(sv(i, 1))) = 0 Then c00 = c00 & "|" & sv(i, 1)
    Next i
      sv2 = Split(c00, "|")
 For j = 1 To UBound(sv2)
   With .Cells(1).CurrentRegion
      .AutoFilter 1, , 7, Array(2, Format(sv2(j), "m/d/yyyy"))
      sv2(j) = Replace(sv2(j), ":", "_")
    
      If IsError(Evaluate("'" & sv2(j) & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = sv2(j)
         Sheets(sv2(j)).Cells(1).CurrentRegion.Clear
          arr = .Offset(1).SpecialCells(12)
         Sheets(sv2(j)).Cells(1).Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)
         Sheets(sv2(j)).Columns.AutoFit
        .AutoFilter
    End With
  Next j
 End With
End Sub

Mag ook met een lus minder.
Code: 
Sub hsv()
Dim sv, sv2, arr, i As Long, j As Long, c00 As String
With Sheets("form responses 1")
sv = .Cells(1).CurrentRegion
    For i = 2 To UBound(sv)
     If InStr(c00, Day(sv(i, 1))) = 0 Then
      c00 = c00 & "|" & sv(i, 1)
 With .Cells(1).CurrentRegion
      .AutoFilter 1, , 7, Array(2, Format(sv(i, 1), "m/d/yyyy"))
      sv(i, 1) = Replace(sv(i, 1), ":", "_")
         If IsError(Evaluate("'" & sv(i, 1) & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = sv(i, 1)
           Sheets(sv(i, 1)).Cells(1).CurrentRegion.Clear
          arr = .Offset(1).SpecialCells(12)
         Sheets(sv(i, 1)).Cells(1).Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)
         Sheets(sv(i, 1)).Columns.AutoFit
        .AutoFilter
    End With
    End If
  Next i
 End With
End Sub
 

Bijlagen

Laatst bewerkt:
HSV zei:
Hierbij filter ik op dag.
Code: 
Sub hsv()
Dim sv, sv2, arr, i As Long, j As Long, c00 As String
With Sheets("form responses 1")
sv = .Cells(1).CurrentRegion
    For i = 2 To UBound(sv)
     If InStr(c00, Day(sv(i, 1))) = 0 Then c00 = c00 & "|" & sv(i, 1)
    Next i
      sv2 = Split(c00, "|")
 For j = 1 To UBound(sv2)
   With .Cells(1).CurrentRegion
      .AutoFilter 1, , 7, Array(2, Format(sv2(j), "m/d/yyyy"))
      sv2(j) = Replace(sv2(j), ":", "_")
    
      If IsError(Evaluate("'" & sv2(j) & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = sv2(j)
         Sheets(sv2(j)).Cells(1).CurrentRegion.Clear
          arr = .Offset(1).SpecialCells(12)
         Sheets(sv2(j)).Cells(1).Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)
         Sheets(sv2(j)).Columns.AutoFit
        .AutoFilter
    End With
  Next j
 End With
End Sub

Mag ook met een lus minder.
Code: 
Sub hsv()
Dim sv, sv2, arr, i As Long, j As Long, c00 As String
With Sheets("form responses 1")
sv = .Cells(1).CurrentRegion
    For i = 2 To UBound(sv)
     If InStr(c00, Day(sv(i, 1))) = 0 Then
      c00 = c00 & "|" & sv(i, 1)
 With .Cells(1).CurrentRegion
      .AutoFilter 1, , 7, Array(2, Format(sv(i, 1), "m/d/yyyy"))
      sv(i, 1) = Replace(sv(i, 1), ":", "_")
         If IsError(Evaluate("'" & sv(i, 1) & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = sv(i, 1)
           Sheets(sv(i, 1)).Cells(1).CurrentRegion.Clear
          arr = .Offset(1).SpecialCells(12)
         Sheets(sv(i, 1)).Cells(1).Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)
         Sheets(sv(i, 1)).Columns.AutoFit
        .AutoFilter
    End With
    End If
  Next i
 End With
End Sub
Klik om te vergroten...

Bedankt, dat werkt, maar blijkbaar alleen voor de eerste drie data-rijen.... Hoe kan ik de code aanpassen zodat ook alle volgende rijen van tabblad 1 worden gekopieerd en getransponeerd?
 
VenA zei:
En wat is er makkelijkere aan? Dat iemand anders het wiel opnieuw kan gaan uitvinden? Wijzig de code van @HSV in het andere draadje alles staat erin om ook aan deze vraag te voldoen. (Er staat dan zelfs teveel in om aan deze vraag te voldoen wat het nog makkelijker maakt om de code aan te passen)
Klik om te vergroten...

De code van HSV werkte voor mij niet en ik heb er zelf te weinig verstand van om het probleem op te lossen. Vandaar dat ik een nieuw draadje opende met een iets andere vraag. Als ik een Excel-tovenaar was zoals sommigen hier hoefde ik ook niet om hulp te vragen.
 
Gelieve niet quoten, mijn eigen geplaatste berichten maakt het daar niet duidelijker van.

De code werkt op alle rijen mits er geen lege rijen tussen andere rijen zitten.

Mits een kleine aanpassing in de code.
Code: 
If InStr(c00, "|" & Day(sv(i, 1)) & "|") = 0 Then
 
Laatst bewerkt:
Code: 
Sub hsv()
Dim sv, sv2, arr, i As Long, j As Long, c00 As String
With Sheets("form responses 1")
sv = .Cells(1).CurrentRegion
    For i = 2 To UBound(sv)
    If InStr(c00, "|" & Day(sv(i, 1)) & "|") = 0 Then
     c00 = c00 & "|" & sv(i, 1)
 With .Cells(1).CurrentRegion
      .AutoFilter 1, , 7, Array(2, Format(sv(i, 1), "m/d/yyyy"))
      sv(i, 1) = Replace(sv(i, 1), ":", "_")
         If IsError(Evaluate("'" & sv(i, 1) & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = sv(i, 1)
           Sheets(sv(i, 1)).Cells(1).CurrentRegion.Clear
          arr = .Offset(1).SpecialCells(12)
         Sheets(sv(i, 1)).Cells(1).Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)
         Sheets(sv(i, 1)).Columns.AutoFit
        .AutoFilter
    End With
    End If
  Next i
 End With
End Sub

Ik waardeer de inspanningen, echt(!), maar bovenstaande code levert niet het gewenste resultaat op voor het bijgevoegde document (Bekijk bijlage Untitled form (Responses) - kopie.xlsm).

Wat ik zou willen is dat op tabblad 2 rij 1 van tabblad komt, op tabblad 3 rij 2 van tabblad 1, op tabblad 4 rij 3 van tabblad 1, enzovoort tot de eerste lege rij wordt bereikt.
 
Onmogelijk met die timestamp.
Twee bladen met dezelfde naam gaat niet.
 
In mijn laatste bijlage zijn alle timestamps uniek....? Lijkt missschien niet zo omdat er twee keer twee dezelfde datums inzitten, maar in de cel staat ook nog een tijd die uniek is.
 
Laatst bewerkt:
HSV zei:
Twee bladen met dezelfde naam gaat niet.
Klik om te vergroten...

Dat lijkt me op zich logisch (vandaar mijn vraag naaar een combinatie van cel A4 en A5 als tabbladnaam), dus dan zullen de timestamps uniek moeten zijn als je daarop filtert.
 
Als timestamp toch uniek is.
Toch maar een zekerheidje ingebouwd.

Code: 
Sub hsv()
Dim sv, arr, i As Long, c00 As String, c01 As String
sv = Sheets("form responses 1").Cells(1).CurrentRegion
 For i = 2 To UBound(sv)
    If InStr(c00, "|" & sv(i, 1) & "|") = 0 Then
        c00 = c00 & "|" & sv(i, 1)
          c01 = Replace(sv(i, 1), ":", "_")
           If IsError(Evaluate("'" & c01 & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = c01
             With Sheets(c01).Cells(1)
               .CurrentRegion.Clear
               arr = Application.Index(sv, i, 0)
               .Resize(UBound(arr)) = Application.Transpose(arr)
               .Columns.AutoFit
            End With
    End If
  Next i
End Sub
 
Laatst bewerkt:
Dank je wel HSV! Dat werkt! Elke rij vanaf rij 2 op tabblad 1 komt nu op een eigen tabblad terecht, getransponeerd. Hier kan ik mee verder, nogmaals dank!
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan