vba - viele matrixformeln ersetzen?

[snb]

@Att

Dann reicht diese Code:

Code:

Sub M_snb()
   sn = Sheets("Übersicht").Cells(1).CurrentRegion
   
   With CreateObject("Scripting.Dictionary")
      For j = 2 To UBound(sn)
         .Item(sn(j, 1)) = .Item(sn(j, 1)) & "_" & sn(j, 2)
      Next
      j = 5
      For Each it In .keys
         Sheets("Übersicht").Cells(30, j).Resize(60) = Application.Transpose(Split(it & .Item(it), "_"))
         j = j + 1
      Next
      
      Sheets("Übersicht").Cells(30, j).CurrentRegion.SpecialCells(2, 16).ClearContents
   End With
End Sub

[atilla]

Hallo snb,

nee, das gilt nicht. Ich habe gestern lange darauf gewartet, dass Du diese Lösung anbietest.
Aber im Grunde unterscheiden sich unsere Codes nicht wesentlich. In meiner Werkstatt sieht es nur aufgeräumter aus.
Am Ende steht da zwar das gleiche Auto, aber meins ist zudem noch sparsamer als Deiner. Deins ist zu puristisch.
Aber in meinem Alter mag ich es etwas Komfortabler.

Der entscheidende Unterschied liegt hier:

Code:

      For Each it In .keys
         Sheets("Tabelle2").Cells(1, j).Resize(60) = Application.Transpose(Split(it & .Item(it), "_"))
         j = j + 1
      Next

Bei noch größeren Datenmengen wird mein Code sicher schneller sein, stimmst Du mir da zu?? Bitte, bitte!


EDIT:
Ach, hätte ich fast vergessen, Dein Code reicht so natürlich nicht aus.
Eine If Abfrage muss noch rein zur Prüfung der Spalte C auf Zahlen.

[atilla]

Hallo Klaus,

so nach dem wir snb etwas geärgert haben nun zu Dir.

Du hast sicher nicht festgestellt, dass mein Code nicht alle Ergebnisse liefert, oder hast Du?

Die letzte Zeile habe ich unterschlagen.
Dann habe ich den Speicher unnötig stark beansprucht mit meiner Array Dimensionierung.

Unten zwei Codevarianten die die gleichen Ergebnisse liefern, sich allein bei der Umsetzung der Anpassung der Spaltenbreite unterscheiden.
Lass beide mal laufen, dann siehst Du den unterschied.

Natürlich erhältst Du mit beiden jetzt alle Ergebnisse.

Code:

Option Explicit

' Bedingtes Transponieren
Sub Bedingtes_Transponieren()
 Dim i As Long, j As Long, k As Long
 Dim zZ As Long
 Dim lngZ As Long
 Dim feld
 Dim vntK
 Dim arr()
 
 Dim c As Object
 Set c = CreateObject("Scripting.Dictionary")
 With Sheets("Übersicht")
   lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
   feld = .Range("A2:C" & lngZ)
   For i = 1 To lngZ - 1
     If IsNumeric(feld(i, 3)) Then
       vntK = feld(i, 1)
'        If InStr(c(vntK), feld(i, 3)) = 0 Then   'wenn wie bei OPA EDGAR keine Doppelten aus Spalte B aufgeführt werden sollen, dann das Hochkomma am Anfang der Zeile entfernen
         c(vntK) = feld(i, 2) & "#" & c(vntK)
'        End If                                   'wenn wie bei OPA EDGAR keine Doppelten aus Spalte B aufgeführt werden sollen, dann das Hochkomma am Anfang der Zeile entfernen
       zZ = Application.Max(zZ, UBound(Split(c(vntK), "#")) + 1)
     End If
   Next
   ReDim arr(c.Count - 1, zZ)
   For Each vntK In c.keys
     arr(k, 0) = vntK
     For j = 0 To UBound(Split(c(vntK), "#"))
       arr(k, j + 1) = Split(c(vntK), "#")(j)
     Next j
     k = k + 1
   Next vntK
 End With

 With Sheets("Tabelle1")   'Name der Zieltabelle
   .Cells.Clear
   Application.ScreenUpdating = False
   .Range(.Cells(1, 1), .Cells(zZ, c.Count)) = Application.Transpose(arr)
   .Range("A1").Resize(, c.Count).EntireColumn.AutoFit   'Spaltenbreite auto anpassen
   Application.ScreenUpdating = True
 End With
End Sub

Sub Bedingtes_Transponieren2()
Dim i As Long, j As Long, k As Long
Dim zZ As Long
Dim lngZ As Long
Dim feld
Dim vntK
Dim arr()

Dim c As Object
Set c = CreateObject("Scripting.Dictionary")
With Sheets("Übersicht")
  lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
  feld = .Range("A2:C" & lngZ)
  For i = 1 To lngZ - 1
    If feld(i, 3) <> "" And IsNumeric(feld(i, 3)) Then
      vntK = feld(i, 1)
'        If InStr(c(vntK), feld(i, 3)) = 0 Then   'wenn wie bei OPA EDGAR keine Doppelten aus Spalte B aufgeführt werden sollen, dann das Hochkomma am Anfang der Zeile entfernen
        c(vntK) = feld(i, 2) & "#" & c(vntK)
'        End If                                   'wenn wie bei OPA EDGAR keine Doppelten aus Spalte B aufgeführt werden sollen, dann das Hochkomma am Anfang der Zeile entfernen
      zZ = Application.Max(zZ, UBound(Split(c(vntK), "#")) + 1)
    End If
  Next
  ReDim arr(c.Count - 1, zZ)
  For Each vntK In c.keys
    For j = 0 To UBound(Split(c(vntK), "#"))
      arr(k, j) = Split(c(vntK), "#")(j)
    Next j
    k = k + 1
  Next vntK
End With
 
With Sheets("Tabelle1")   'Name der Zieltabelle
  .Cells.Clear
  Application.ScreenUpdating = False
  .Range("A1").Offset(1, 0).Resize(zZ, c.Count) = Application.Transpose(arr)
  .Range("A1").Resize(, c.Count).EntireColumn.AutoFit   'Spaltenbreite auto anpassen
  .Columns(1).WrapText = True    'Zellen der ersten Zeile Zeilenumbruch
  .Range("A1").Resize(, c.Count) = c.keys
End With
Application.ScreenUpdating = True
End Sub

[snb]

Code:

Sub M_snb()
   sn = Sheets("Übersicht").Cells(1).CurrentRegion
   
   With CreateObject("Scripting.Dictionary")
      For j = 2 To UBound(sn)
         If IsNumeric(sn(j, 3)) Then .Item(sn(j, 1)) = .Item(sn(j, 1)) & "_" & sn(j, 2)
      Next
      For Each it In .keys
         .Item(it) = Split(it & .Item(it) & String(60 - UBound(Split(.Item(it), "_")), "_"), "_")
      Next
      
      sn = Application.Transpose(Application.Index(.items, 0, 0))
      Sheets("Übersicht").Cells(30, 5).Resize(UBound(sn), UBound(sn, 2)) = sn
   End With
End Sub

[atilla]

Hallo snb,

danke für die vielen Worte und die Ergänzung im Code.

Aber was ist hiermit:

Code:

Bei noch größeren Datenmengen wird mein Code sicher schneller sein, stimmst Du mir da zu??

[snb]

Könntest du selbst herausfinden ?

[atilla]

Hallo snb,

könnte ich, aber ich möchte dass Du mir Recht gibst.


Aber da Du jetzt da bist, folgendes:

Ich lese ja Werte so ein:

arr(k, j - 1) = Split(c(vntK), "#")(j)

wenn ich sie so einlese:

arr(k) = Join(Split(c(vntK), "#"), ", ")


wie kann ich diese dann in die Tabelle schreiben?

Ich kriege es gerade nicht hin.

[snb]

Es kann noch etwas einfacher:

Code:

Sub M_snb()
   With Sheets("Übersicht")
     .Cells(1).CurrentRegion.Sort .Cells(1), , .Cells(1, 2), , , , , 1
     sn = .Cells(1).CurrentRegion
  End with

   With CreateObject("Scripting.Dictionary")
      For j = 2 To UBound(sn)
         If IsNumeric(sn(j, 3)) And sn(j, 2) <> "" And InStr(.Item(sn(j, 1)) & "_", "_" & sn(j, 2) & "_") = 0 Then .Item(sn(j, 1)) = .Item(sn(j, 1)) & "_" & sn(j, 2)
      Next
      For Each it In .keys
         .Item(it) = Split(it & .Item(it) & String(60 - UBound(Split(.Item(it), "_")), "_"), "_")
      Next
      
      Sheets("Übersicht").Cells(30, 5).Resize(60, .Count) = Application.Transpose(Application.Index(.items, 0, 0))
      Sheets("Übersicht").Cells(30, 5).Resize(60, .Count).EntireColumn.AutoFit
   End With
End Sub

[snb]

Join(Split(c(vntK), "#"), ", ")

ist doch identisch zu

replace(c(vntK,"#",",")

??

Schau mal:

http://www.snb-vba.eu/VBA_Arrays_en.html#L_6.13.1.3

[atilla]

Hallo snb,

tolle Lösungen, die Du anbietest.

Ich brauch aber etwas Zeit, um dahinterzusteigen.  Und wenn ich begriffen habe, was Du da machst, heißt es noch lange nicht, dass ich es behalten und anwenden kann.
Dafür nutze ich VBA zu selten. Meist eben hier und dann zeitlich begrenzt aus Spaß an der Freud.

Aber ich schau mir die Sachen noch genauer an.
Beim letzten Code verstehe ich nur nicht, warum du die Zahl 60 nutzt. Da müsste doch ein errechneter Wert stehen.

Nun brauchst Du auch nicht mehr bestätigen, dass ich schneller bin. Das bist Du jetzt eindeutig. :@