Zählen und ausgeben von Werten.

[fredo]

Hallo,

ich habe folgende Problemstellung: Ich habe eine Liste von 2 verschiedenen IDs.

Ich würde gerne über ein Makro verfügen, welches mir eine der 2 Listen durchgeht je nachdem welche ich möchte.
Es notiert jeweils nach genau 81 Werten die Werte nacheinander in einer Zelle rechts daneben mit Kommatrennung: "ID1,ID2,ID3,...,ID81".
Dies macht es solange bis keine 81 Werte nacheinander mehr kommen und notiert den Rest rechts neben den letzten Wert.

Ich habe die mögliche Darstellung in einer Exceldatei einmal dargestellt.

Die Spalte wo die Tabelle steht ist dabei nicht immer die gleiche. Nur der Name, ID1 bzw ID2 stehen immer über der Tabelle. Auch die Anzahl der Werte ist sehr unterschiedlich. Manchmal mehrere tausend, manchmal nur paar hundert.

Bei Fragen zur Aufgabenstellung einfach nachfragen. Bin mir sicher da gibt es verständlichkeitsprobleme.

Danke für eure Hilfe.

Gruß,
Fredo

[snb]

Code:

Sub M_snb()
   sn = Application.Transpose(Sheet1.Columns(Sheet1.Rows(1).Find("ID1").Column).SpecialCells(2))
   ReDim sp(UBound(sn) \ 81, 0)
   
   For j = 2 To UBound(sn)
     sp((j - 1) \ 81, 0) = sp((j - 1) \ 81, 0) & "," & sn(j)
   Next
   
   sheet1.Cells(1, 10).Resize(UBound(sp) + 1) = sp
End Sub

[fredo]

Hallo snb,

ich habe dein Code ausprobiert und folgendes rausbekommen.

Die Daten stehen nicht hinter den jeweils 81zigsten Zeilen, sondern gesammelt oben rechts.

Außerdem warden bei den ersten Id's nur die ersten 80 gezählt.

Weißt du wie man das beheben kann?

Wenn ich die Daten von Spalte ID2 sehen möchte muss ich nur den jeweiligen Namen im Code ändern nehme ich an.

Gruß,
Fredo

[snb]

Wenn du die Code (nur 6 Sätze) verstehst kannst du die einfach anpassen.

[fredo]

Hallo snb,

Um ehrlich zu sein habe ich den Code nicht wirklich verstanden.
Habe mit VBA nicht wirklich Erfahrung.

Ich hab mal versucht bisschen was zu verstehen und hab den Code kommentiert. Da wird wahrscheinlich sehr viel Falsches dabei sein, wenn nicht sogar alles. :s

Vielleicht kannst du mich da ein bisschen verbessern mit den Kommentierungen?
Das wäre sehr hilfreich. Danke!

Code:

Sub M_snb()  

//Anfang des Moduls “M_snb”

  sn = Application.Transpose(Sheet1.Columns(Sheet1.Rows(1).Find("ID1").Column).SpecialCells(2))  

//Application.transpose wird die Werte welche in 1Spalte*81Zeilen steht in 1Zeile*81Spalten umkehren
 
ReDim sp(UBound(sn) \ 81, 0)

// ReDim ändert die Größe eines Arrays. Ubound würde den Wert 81 zurückgeben da das Array aus 81 Spalten besteht. deshalb teilst du es durch 81 und reduzierst es somit auf eine Spalte?
// Was die ",0" am Ende von ReDim bedeutet versteh ich allerdings nicht. Dann würde es sich ja auf das 0 Element des Arrays beziehen. Dachte das fängt aber bei 1 an. (Beziehe mich auf dieses Beispiel hier: https://msdn.microsoft.com/de-de/library/95b8f22f(v=vs.90).aspx)
 
  For j = 2 To UBound(sn)    

// Hier beginnt der eigentliche Code für den Ablauf oder? j beginnt bei 2 und wird bei jeder Schleife eins hochgezählt?
// Deshalb schreibt er die Ergebnisse auch in die Spalte j hab ich Recht?
// "to UBound(sn)" weil nun diese Funktion angewendet wird?

    sp((j - 1) \ 81, 0) = sp((j - 1) \ 81, 0) & "," & sn(j)

// Schreibt jetzt in die Spalte "j-1" die ersten 81 Werte untereinander und dreht sie um?
  Next
 
  sheet1.Cells(1, 10).Resize(UBound(sp) + 1) = sp

// sheet1.cells makiert Zellen, in diesem Fall die Zelle J1.resize ändert die Anzahl des neu markierten Bereich auf UBound+1?

End Sub

//Ende des Moduls "M_snb"

[fredo]

Code:

sheet1.Cells(1, 10).Resize(UBound(sp) + 1) = sp
End Sub

Also ich hab schon rausgefunden, dass wenn ich "sheet1.Cells(1, 10)" in "sheets1.Cells(82, 10)" umschreibe, die Werte in J82 abwärts geschrieben werden.
Allerdings habe ich nicht rausgefunden wie ich zwischen den einzelnen Zellen einen Abstand von 81 Werten herstellen kann.
Ein weiteres Problem was ich nicht behoben bekomme, ist das Komma vor dem jeweils ersten Wert wegzubekommen.

[fredo]

Zur Info, hab auch mal hier nachgefragt:

Thema in anderem Forum

[schauan]

Hallo Fredo,

schaue Dir diese variante mal an.:

Code:

Sub Liste1()
'Variablendeklarationen
'Variant-Array
Dim arrZ
'Long
Dim iCnt1&
'Zeilenzaehler Startwert setzen
iCnt1 = 1
'Array (re)dimansionieren
ReDim arrZ(1 To 82)
'Schleife solange keine Leerzelle in Spalte D (4) auftritt
Do While Cells(iCnt1, 4).Offset(1, 0) <> ""
 'Wenn Rest der Division der Zeilennummer durch 82 = = ist, (der 82. Eintrag erreicht ist), dann
 If iCnt1 Mod 82 = 0 Then
   '82. Zelleintrag ins Array uebernehmen
   arrZ(82) = Cells(iCnt1, 4).Offset(1, 0)
   'Array in gleicher Zeile ab Spalte G (6) ausgeben
   Cells(1 + Int(iCnt1 / 82) * 82, 6).Resize(, 82) = arrZ
   'Array zuruecksetzen (leeren)
   ReDim arrZ(1 To 82)
   'Zeilenzaehler hochsetzen
   iCnt1 = iCnt1 + 1
 'Alternativ zu   'Wenn Rest der Division der Zeilennummer durch 82 = = ist, (der 82. Eintrag erreicht ist), dann
 Else
   'Zelleintrag ins Array uebernehmen
   arrZ(iCnt1 Mod 82) = Cells(iCnt1, 4).Offset(1, 0)
   'Zeilenzaehler hochsetzen
   iCnt1 = iCnt1 + 1
 'Ende Wenn Rest der Division der Zeilennummer durch 82 = = ist, (der 82. Eintrag erreicht ist), dann
 End If
'Ende Schleife solange keine Leerzelle in Spalte D (4) auftritt
Loop
'Wenn am Ende keine 82 Zeilen erreicht wurden, dann
If iCnt1 Mod 82 <> 0 Then
 'restliche Eintraege des Array in gleicher Zeile ab Spalte G (6) ausgeben
 Cells(iCnt1, 6).Resize(, 82) = arrZ
'Ende Wenn am Ende keine 82 Zeilen erreicht wurden, dann
End If
End Sub

Es würde aber auch einfacher gehen, je 82 Zeilen markieren, kopieren und transponiert einfügen - auch per Makro - siehe die Lösung von snb.

[Kuwer]

Hallo Fredo,

ich hätte auch noch das:

Modul Modul_Kuwer

Option Explicit 
 
Sub Kuwer() 
  Dim i As Long 
  Dim lngAnzahlZeilenUeberschrift As Long 
  Dim lngIntervall As Long 
  Dim lngLetzteZeile As Long 
  Dim lngSpalteID As Long, lngSpalteAusgabe As Long 
   
  lngAnzahlZeilenUeberschrift = 1 
  lngIntervall = 81 
   
  lngSpalteID = 4 
  lngSpalteAusgabe = 6 
  lngLetzteZeile = Cells(Rows.Count, lngSpalteID).End(xlUp).Row 
  For i = lngIntervall + lngAnzahlZeilenUeberschrift To lngLetzteZeile Step lngIntervall 
    Cells(i, lngSpalteAusgabe).Value = Join(Application.Transpose(Cells(i - lngIntervall + 1, lngSpalteID).Resize(lngIntervall).Value), ",") 
  Next i 
  i = lngLetzteZeile Mod lngIntervall 
  If i > 0 Then 
    Cells(lngLetzteZeile, lngSpalteAusgabe).Value = Join(Application.Transpose(Cells(lngLetzteZeile - i + 1 + lngAnzahlZeilenUeberschrift, lngSpalteID).Resize(i).Value), ",") 
  End If 
   
  lngSpalteID = 5 
  lngSpalteAusgabe = 7 
  lngLetzteZeile = Cells(Rows.Count, lngSpalteID).End(xlUp).Row 
  For i = lngIntervall + lngAnzahlZeilenUeberschrift To lngLetzteZeile Step lngIntervall 
    Cells(i, lngSpalteAusgabe).Value = Join(Application.Transpose(Cells(i - lngIntervall + 1, lngSpalteID).Resize(lngIntervall).Value), ",") 
  Next i 
  i = lngLetzteZeile Mod lngIntervall 
  If i > 0 Then 
    Cells(lngLetzteZeile, lngSpalteAusgabe).Value = Join(Application.Transpose(Cells(lngLetzteZeile - i + 1 + lngAnzahlZeilenUeberschrift, lngSpalteID).Resize(i).Value), ",") 
  End If 
End Sub 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 14 - mit VBAHTML 12.6.0

Es ist vielleicht leichter anpassbar/verständlicher.

Gruß Uwe

[schauan]

Hallöchen,

dann eventuell nochmal das mit dem Transponieren, aber auf meine Art

Code:

Sub Transpo()
'Variablendeklarationen
'Long
Dim iCnt1&
'Startzeile festlegen
iCnt1 = 1
'Schleife solange in der naechsten Zeile etwas steht
Do While Cells(iCnt1, 4).Offset(1, 0) <> ""
  'naechste 82 Zellen transponieret ab Zelle in Spalte & in gleicher Zeile
  Cells(WorksheetFunction.Min(iCnt1 + 82, Cells(Rows.Count, 4).End(xlUp).Row), 6).Resize(1, 82) = _
    Application.Transpose(Range(Cells(iCnt1 + 1, 4), Cells(iCnt1 + 83, 4)))
  'Zeilenzaehler 82 Zeilen hochsetzen
  iCnt1 = iCnt1 + 82
'Ende Schleife solange in der naechsten Zeile etwas steht
Loop
End Sub