Microsoft Excel

Herbers Excel/VBA-Archiv

Adressliste, transponieren? | Herbers Excel-Forum


Betrifft: Adressliste, transponieren? von: Judith
Geschrieben am: 03.02.2012 09:03:05

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

  

Betrifft: AW: Adressliste, transponieren? von: Rudi Maintaire
Geschrieben am: 03.02.2012 09:35:00

Hallo,

 ABCDEFGH
11000MüllerHansMusterstrasse 1720095Hamburg  
21001MeierHubert     
31002ReibachKarolineTestweg 2280331München089 9234567 

ZelleFormel
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);"")


Formel aus A2 nach unten und Formel aus B1 nach rechts und unten kopieren.

Gruß
Rudi


  

Betrifft: VBA Adressliste, transponieren? von: Josef Ehrensberger
Geschrieben am: 03.02.2012 09:47:07


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 »



  

Betrifft: AW: VBA Adressliste, transponieren? von: Judith
Geschrieben am: 03.02.2012 13:13:10

Hallo Rudi, hallo Sepp,
ich werde noch verrückt mit Euch, aber im positiven Sinne! Wie kann man nur sowas aus dem Ärmel zaubern???

Ich bin sicher, beides wird klappen. Jetzt liegt es noch an mir, Eure Antworten zu analysieren.

Vielen, vielen Dank und viele Grüße!

Judith