Adressliste, transponieren?

Hallo,
ich habe mal wieder eine ellenlange Adressliste, die ich umbauen muss. Es wäre super, wenn mir jemand dabei helfen könnte, das zu automatisieren.
Siehe Beispiel: https://www.herber.de/bbs/user/78708.xls
Die Adressnummer ist ausschlaggebend. Alle Daten, die die gleiche Adressnummer (Spalte A) haben, sollen in eine Zeile ausgegeben werden. Es sind unterschiedlich viele Informationen zu einer Adressnummer gespeichert, man kann also nicht sagen, jede Adressnummer hat z. B. 6 Informationen.
Wie das manuell geht, habe ich schon rausgefunden. Ich habe nach der Adressnummer gefiltert, die Informationen in Spalte B kopiert, und mit "transponieren" in ein neues Tabellenblatt eingefügt. Bei tausenden von Datensätzen kann das aber etwas dauern.
Vielen Dank, vielleicht kann mir jemand helfen oder einen Tipp geben, wie man das schneller machen könnte (ein paar VBA Kenntnisse habe ich).
Viele Grüße
Judith

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Judith,

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub transposeList()
  Dim vntList As Variant, vntUnique As Variant, vntMaxEntry As Variant
  Dim vntRet As Long
  Dim lngColCount As Long, lngRow As Long, lngCol As Long
  Dim objSh As Worksheet
  
  With Sheets("Tabelle1")
    vntList = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    vntUnique = toArraySorted(vntList)
    vntMaxEntry = Evaluate("MODE(" & .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Address & ")")
    lngColCount = Application.CountIf(.Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row), vntMaxEntry)
    Redim vntList(1 To UBound(vntUnique, 1) + 1, 1 To lngColCount + 1)
    For lngRow = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
      vntRet = Application.Match(.Cells(lngRow, 1), vntUnique, 0)
      If IsNumeric(vntRet) Then
        If IsEmpty(vntList(vntRet, 1)) Then vntList(vntRet, 1) = .Cells(lngRow, 1)
        lngCol = Application.CountIf(.Range(.Cells(2, 1), .Cells(lngRow, 1)), Cells(lngRow, 1))
        vntList(vntRet, lngCol + 1) = .Cells(lngRow, 2)
      End If
    Next
  End With
  
  Set objSh = Worksheets.Add
  objSh.Cells(1, 1).Resize(UBound(vntList, 1), UBound(vntList, 2)) = vntList
  
  Set objSh = Nothing
End Sub


Public Function toArraySorted(Field As Variant, Optional Uniqe As Boolean = True) As Variant
  'by ransi
  Dim objArrayList As Object
  Dim lngR As Long, lngC As Long
  
  On Error GoTo ErrExit
  
  Set objArrayList = CreateObject("System.Collections.Arraylist")
  
  With objArrayList
    For lngR = LBound(Field, 1) To UBound(Field, 1)
      For lngC = LBound(Field, 2) To UBound(Field, 2)
        If Not .Contains(Field(lngR, lngC)) Or Not Uniqe Then
          If Field(lngR, lngC) <> "" Then .Add Field(lngR, lngC)
        End If
      Next
    Next
    .Sort
    toArraySorted = .toArray
  End With
  
  Exit Function
  ErrExit:
  toArraySorted = -1
End Function

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

	A	B	C	D	E	F	G	H
1	1000	Müller	Hans	Musterstrasse 17	20095	Hamburg
2	1001	Meier	Hubert
3	1002	Reibach	Karoline	Testweg 22	80331	München	089 9234567

Zelle	Formel
A1	=MIN(Tabelle1!A:A)
A2	=WENN(MAX(Tabelle1!A:A)=MAX(A$1:A1);"";KGRÖSSTE(Tabelle1!A:A;ZÄHLENWENN(Tabelle1!A:A;">"& A1)))
B1	=WENN(SPALTE()-2<ZÄHLENWENN(Tabelle1!$A:$A;$A1);INDEX(Tabelle1!$B:$B;VERGLEICH($A1;Tabelle1!$A:$A;)+SPALTE()-2);"")

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread