Live-Forum - Die aktuellen Beiträge
Datum
Titel
23.04.2024 17:00:22
Summe und Ausgabe
23.04.2024 16:27:34
Excel Starthinweis - Arbeitsmappenleistung überprüfen ...
23.04.2024 16:15:16
Mittels VBA vordefinierte Kommentare in Zellen einfügen?
23.04.2024 14:59:21
Zellformel in VBA
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
940to944
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
940to944
940to944
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Einmalige Auflistung von Werten aus einer Tabelle

Einmalige Auflistung von Werten aus einer Tabelle
14.01.2008 19:46:00
Werten
Schönen guten Abend werte Excelisten,
dies ist mein erster Beitrag im Forum und ich hoffe, dass mir hier jemand weiterhelfen kann.
Das Problem schien für mich erst ganz einfach lösbar...Pustekuchen...war es dann irgendwie
doch nicht.
Ich habe in einer Tabelle in der Spalte B mehrere verschiedene Währungen, die unterschiedlich oft vorkommen, untereinander in den Zellen stehen. Unter der Tabelle sollen nun die Währungen, jeweils einmal untereinander in die Zellen geschrieben werden, um Sie danach für eine Summewenn-Funktion
zu verwenden. Ich habe die Datei einmal hochgeladen um mein Problem zu verdeutlichen.

Die Datei https://www.herber.de/bbs/user/49014.xls wurde aus Datenschutzgründen gelöscht


Problem ist, dass die Währungen, sowie die Länge der Tabelle sich ständig ändern. Da ich diese
Meldung jeden Tag erstellen muss, wäre es für mich eine erheblich Erleichterung, wenn man dies
"automatisieren" könnte. (Pivot-Tabellen kann ich leider aufgrund der Weiterverwendung nicht
benutzen)
Ich habe natürlich selber schon nach Lösungen in diesem und anderen Foren gesucht, allerdings
keine hilfreiche oder für mich verständliche Lösung gefunden. Falls es schon mal gepostet sein
sollte tuts mir Leid, es ist bloß schwer nach diesem Thema zu suchen.
Hoffe ich konnte es hinreichend erklären. Danke vorab für eure Bemühungen!!
Sanfte Grüße
Aexel
P.S.: Absolut tolles Forum, was sehr viel Freude bereitet.

21
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Einmalige Auflistung von Werten aus einer Tabe
14.01.2008 20:29:08
Werten
HAllo Aexel
Die Berechnung kannst du so machen:
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit


Public Sub test()
Dim Arr
Dim L As Long
Dim Zelle As Range
Dim Dic1
Dim Dic2
Arr = Sheets("Tabelle2").Range("a1").CurrentRegion
Set Zelle = Sheets("Tabelle2").Range("B65536").End(xlUp).Offset(2, 0)
Set Dic1 = CreateObject("Scripting.dictionary")
Set Dic2 = CreateObject("Scripting.dictionary")
On Error Resume Next
For L = 2 To UBound(Arr)
    Dic1(Arr(L, 2)) = Dic1(Arr(L, 2)) + Arr(L, 3)
    Dic2(Arr(L, 2)) = Dic2(Arr(L, 2)) + Arr(L, 4)
Next
'Ausgeben
Zelle.Resize(Dic1.Count) = WorksheetFunction.Transpose(Dic1.keys)
Zelle.Offset(0, 1).Resize(Dic1.Count) = WorksheetFunction.Transpose(Dic1.items)
Zelle.Offset(0, 2).Resize(Dic1.Count) = WorksheetFunction.Transpose(Dic2.items)
End Sub

Allerdings nur einmal für die jeweilige Tabelle.
So wie ich das verstanden habe reicht das ja auch...
Die Gelbe Formatierung und die Zellrahmen bekommst du alleine hin ?
ransi

Anzeige
AW: Einmalige Auflistung von Werten aus einer Tabe
14.01.2008 20:40:58
Werten
Hallo Ransi,
ich werds gleich mal ausprobieren und gebe dann später Rückmeldung.
Danke erstmal!!
Grüße
Aexel
P.S.: Ja Formatierung bekomme ich allein hin.

AW: Einmalige Auflistung von Werten aus einer Tabe
14.01.2008 21:08:12
Werten
Hola Ransi,
nach das ist doch Eine-Wand-Frei.....Scripting Dictionary kannte ich ja mal gar nicht.
Aber eine äußerst schicke Lösung.
Ich muss leider weg. Würde aber gerne morgen auf Arbeit probieren, deine Lösung
noch mal nachzuvollziehen und mich ggf. noch mal bei dir melden.
Merci beaucoup!
Aexel

AW: Einmalige Auflistung von Werten aus einer Tabelle
14.01.2008 20:33:00
Werten
Hallo Alex
beginne mit Deiner Tabelle erst ab Zeile 10.
Fixiere Deine Zeile
In der summewenn Formel im oberen Bereich kannst Du
dann $B$11:$B$60000 einsetzten.
gruß Wolfgang

Anzeige
AW: Einmalige Auflistung von Werten aus einer Tabelle
14.01.2008 20:44:00
Werten
Hallo Wolfgang,
danke für die Antwort. Aber ich glaube dies hilft mir
hier nicht weiter. Mein Problem ist ja, dass die Währungen ständig variieren
und ich vorab nicht weiß welche Währungen in der Tabelle vorkommen. Und
alle Währungen kann ich nicht herunterschreiben...es ist jedenfalls nicht so gewünscht.
Trotzdem danke.
Aexel
P.S.: Falls ich dich falsch verstanden hab schreib ruhig noch mal.

AW: Einmalige Auflistung von Werten aus einer Tabelle
14.01.2008 20:43:00
Werten
Hallo Aexel,
ich würde die Auswertung in einem separaten Tabellenblatt machen; hier ein Beispiel, die Auswertung findest du immer aktuell im Blatt "Auswertung", da immer bei dessen Aktivierung ein Makro im Codefenster der Tabelle anspringt:
https://www.herber.de/bbs/user/49019.xls
Gruß,
Beate

Anzeige
AW: Einmalige Auflistung von Werten aus einer Tabelle
14.01.2008 20:55:27
Werten
Hallo Beate,
tolle Lösung!! Find ich gut. Also hier funzt alles wunderbar. Ich werds morgen
noch mal auf Arbeit ausprobiern. Wenn da auch alles ok ist lass ich es dich wissen.
Es kann nämlich sein, dass ich bei dieser Tabelle dann kein zweites Tabellenblatt
einfügen darf.
Herzliches Dankeschön.
Aexel

AW: Einmalige Auflistung von Werten aus einer Tabelle
14.01.2008 20:57:16
Werten
Hallo Aexel,
so könnte es gehen: Makro in ein allgemeines Modul kopieren


Option Explicit
Type Waehrg
   sWaehrg   As String
   dKauf     As Double
   dVerk     As Double
End Type
Public Sub NachWaehrung()
Dim lZeile       As Long
Dim lLetzte      As Long
Dim WaehrgTab()  As Waehrg
Dim iIndex       As Integer
   With Worksheets("Tabelle2")  ' <== Tabellenblattnamen ggf. anpassen !!!
      lLetzte = .Cells(Rows.Count, 2).End(xlUp).Row
      ReDim WaehrgTab(1 To lLetzte)
      For lZeile = 2 To lLetzte
         If WaehrgTab(1).sWaehrg = "" Then
            WaehrgTab(1).sWaehrg = .Cells(lZeile, 2).Value
            If .Cells(lZeile, 3).Value <> "" Then
               If IsNumeric(.Cells(lZeile, 3).Value) Then
                  WaehrgTab(1).dKauf = CDbl(.Cells(lZeile, 3).Value)
               End If
            End If
            If .Cells(lZeile, 4).Value <> "" Then
               If IsNumeric(.Cells(lZeile, 4).Value) Then
                  WaehrgTab(1).dVerk = CDbl(.Cells(lZeile, 4).Value)
               End If
            End If
         Else
            For iIndex = 1 To UBound(WaehrgTab)
               If WaehrgTab(iIndex).sWaehrg = .Cells(lZeile, 2).Value Then
                  If .Cells(lZeile, 3).Value <> "" Then
                     If IsNumeric(.Cells(lZeile, 3).Value) Then
                        WaehrgTab(iIndex).dKauf = WaehrgTab(iIndex).dKauf + _
                           CDbl(.Cells(lZeile, 3).Value)
                     End If
                  End If
                  If .Cells(lZeile, 4).Value <> "" Then
                     If IsNumeric(.Cells(lZeile, 4).Value) Then
                        WaehrgTab(iIndex).dVerk = WaehrgTab(iIndex).dVerk + _
                           CDbl(.Cells(lZeile, 4).Value)
                     End If
                  End If
                  Exit For
               ElseIf WaehrgTab(iIndex).sWaehrg = "" Then
                  WaehrgTab(iIndex).sWaehrg = .Cells(lZeile, 2).Value
                  If .Cells(lZeile, 3).Value <> "" Then
                     If IsNumeric(.Cells(lZeile, 3).Value) Then
                        WaehrgTab(iIndex).dKauf = CDbl(.Cells(lZeile, 3).Value)
                     End If
                  End If
                  If .Cells(lZeile, 4).Value <> "" Then
                     If IsNumeric(.Cells(lZeile, 4).Value) Then
                        WaehrgTab(iIndex).dVerk = CDbl(.Cells(lZeile, 4).Value)
                     End If
                  End If
                  Exit For
               End If
            Next iIndex
         End If
      Next lZeile
      lLetzte = lLetzte + 2
      For iIndex = 1 To UBound(WaehrgTab)
         If WaehrgTab(iIndex).sWaehrg <> "" Then
            lLetzte = lLetzte + 1
            .Cells(lLetzte, 2).Value = WaehrgTab(iIndex).sWaehrg
            .Cells(lLetzte, 3).Value = WaehrgTab(iIndex).dKauf
            .Cells(lLetzte, 4).Value = WaehrgTab(iIndex).dVerk
         End If
      Next iIndex
   End With
End Sub


Gruß Peter
Anzeige
AW: Einmalige Auflistung von Werten aus einer Tabelle
14.01.2008 21:31:00
Werten
Hallo Peter,
auch dir recht herzlichen Dank. Funktioniert alles super. Ich
werd mir dein Makro morgen noch mal genauer angucken.
Aber schau dir doch auch mal die Lösung von Ransi dazu an.
Finde ich auch sehr interessant!!
Danke vielmals. Auch an die anderen!!
Du, Ihr - habt mir lästige Handarbeit abgenommen.
Fröhliche Grüße
Der überglückliche Aexel

AW: etwas kompakter
14.01.2008 21:14:35
Peter
Hallo Aexel,
hier eine etwas kompaktere Lösung, als es meine vorherige war:


Option Explicit
Type Waehrg
   sWaehrg   As String
   dKauf     As Double
   dVerk     As Double
End Type
Public Sub NachWaehrung()
Dim lZeile       As Long
Dim lLetzte      As Long
Dim WaehrgTab()  As Waehrg
Dim iIndex       As Integer
   With Worksheets("Tabelle2")  ' <== Tabellenblattnamen ggf. anpassen !!!
      lLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
      ReDim WaehrgTab(1 To lLetzte)
      For lZeile = 2 To lLetzte
         For iIndex = 1 To UBound(WaehrgTab)
            If WaehrgTab(iIndex).sWaehrg = .Cells(lZeile, 2).Value Then
               If .Cells(lZeile, 3).Value <> "" Then
                  If IsNumeric(.Cells(lZeile, 3).Value) Then
                     WaehrgTab(iIndex).dKauf = WaehrgTab(iIndex).dKauf + _
                        CDbl(.Cells(lZeile, 3).Value)
                  End If
               End If
               If .Cells(lZeile, 4).Value <> "" Then
                  If IsNumeric(.Cells(lZeile, 4).Value) Then
                     WaehrgTab(iIndex).dVerk = WaehrgTab(iIndex).dVerk + _
                        CDbl(.Cells(lZeile, 4).Value)
                  End If
               End If
               Exit For
            ElseIf WaehrgTab(iIndex).sWaehrg = "" Then
               WaehrgTab(iIndex).sWaehrg = .Cells(lZeile, 2).Value
               If .Cells(lZeile, 3).Value <> "" Then
                  If IsNumeric(.Cells(lZeile, 3).Value) Then
                     WaehrgTab(iIndex).dKauf = CDbl(.Cells(lZeile, 3).Value)
                  End If
               End If
               If .Cells(lZeile, 4).Value <> "" Then
                  If IsNumeric(.Cells(lZeile, 4).Value) Then
                     WaehrgTab(iIndex).dVerk = CDbl(.Cells(lZeile, 4).Value)
                  End If
               End If
               Exit For
            End If
         Next iIndex
      Next lZeile
      lLetzte = lLetzte + 2
      For iIndex = 1 To UBound(WaehrgTab)
         If WaehrgTab(iIndex).sWaehrg <> "" Then
            lLetzte = lLetzte + 1
            .Cells(lLetzte, 2).Value = WaehrgTab(iIndex).sWaehrg
            .Cells(lLetzte, 3).Value = WaehrgTab(iIndex).dKauf
            .Cells(lLetzte, 4).Value = WaehrgTab(iIndex).dVerk
         End If
      Next iIndex
   End With
End Sub


Gruß Peter
Anzeige
AW: etwas kompakter
15.01.2008 14:10:00
Aexel
Hallo Beate, Ransi und Peter,
naja....wie ungerecht die Welt doch ist, siehts leider bei mir auf Arbeit nicht so rosig aus wie in meiner Beispieltabelle. Vielleicht könnt ihr mir ja trotzdem noch helfen.
Rechts neben der Tabelle steht noch eine Spalte (Spalte E), welche je nach Währung und Geschäft mal ein OK enthält und mal nicht. Die Summewenn-Funktion soll nur die Zeilen abgreifen wo in der Spalte E ein OK steht...also quasi Wenn(Spalte E = "OK";Summewenn.....), ansonsten sollen weder Kauf- noch Verkaufwerte mitsummiert werden.
Habs leider nicht geschafft dies alleine einzubauen. Würde mich natürlich über Tipps freuen.
Danke an euch.
Fröhliche Grüße
Aexel
@ Beate: Leider kann ich sdoch kein zweites Blatt anfügen, da diese Datei später noch von einem anderen Makro weiterverwendet wird.

Anzeige
AW: etwas kompakter
15.01.2008 15:14:33
Peter
Hallo Aexel,
so sollte es gehen - auch mit OK


Option Explicit
Type Waehrg
   sWaehrg   As String
   dKauf     As Double
   dVerk     As Double
End Type
Public Sub NachWaehrung()
Dim lZeile       As Long
Dim lLetzte      As Long
Dim WaehrgTab()  As Waehrg
Dim iIndex       As Integer
   With Worksheets("Tabelle2")  ' <== Tabellenblattnamen ggf. anpassen !!!
      lLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
      ReDim WaehrgTab(1 To lLetzte)
      For lZeile = 2 To lLetzte
         If UCase(.Cells(lZeile, 5).Value) = "OK" Then
            For iIndex = 1 To UBound(WaehrgTab)
               If WaehrgTab(iIndex).sWaehrg = .Cells(lZeile, 2).Value Then
                  If .Cells(lZeile, 3).Value <> "" Then
                     If IsNumeric(.Cells(lZeile, 3).Value) Then
                        WaehrgTab(iIndex).dKauf = WaehrgTab(iIndex).dKauf + _
                           CDbl(.Cells(lZeile, 3).Value)
                     End If
                  End If
                  If .Cells(lZeile, 4).Value <> "" Then
                     If IsNumeric(.Cells(lZeile, 4).Value) Then
                        WaehrgTab(iIndex).dVerk = WaehrgTab(iIndex).dVerk + _
                           CDbl(.Cells(lZeile, 4).Value)
                     End If
                  End If
                  Exit For
               ElseIf WaehrgTab(iIndex).sWaehrg = "" Then
                  WaehrgTab(iIndex).sWaehrg = .Cells(lZeile, 2).Value
                  If .Cells(lZeile, 3).Value <> "" Then
                     If IsNumeric(.Cells(lZeile, 3).Value) Then
                        WaehrgTab(iIndex).dKauf = CDbl(.Cells(lZeile, 3).Value)
                     End If
                  End If
                  If .Cells(lZeile, 4).Value <> "" Then
                     If IsNumeric(.Cells(lZeile, 4).Value) Then
                        WaehrgTab(iIndex).dVerk = CDbl(.Cells(lZeile, 4).Value)
                     End If
                  End If
                  Exit For
               End If
            Next iIndex
         End If
      Next lZeile
      lLetzte = lLetzte + 2
      For iIndex = 1 To UBound(WaehrgTab)
         If WaehrgTab(iIndex).sWaehrg <> "" Then
            lLetzte = lLetzte + 1
            .Cells(lLetzte, 2).Value = WaehrgTab(iIndex).sWaehrg
            .Cells(lLetzte, 3).Value = WaehrgTab(iIndex).dKauf
            .Cells(lLetzte, 4).Value = WaehrgTab(iIndex).dVerk
         End If
      Next iIndex
   End With
End Sub 


Gruß Peter
Anzeige
1x helfen bitte...zum mitnehmen :)
16.01.2008 11:19:00
Aexel
Hallo Peter,
vorerst mal herzlichen Dank für deine tolle Mithilfe. Muss mich halt noch ein "wenig" in VBA reinfuchsen
um so was irgendwann einmal alleine durchführen zu können.
Leider hatte ich mich bei meiner letzten Nachricht ein wenig blöd, ja falsch ausgedrückt. Eigentlich wollte ich, dass sich die Währungen, die sich in der Tabelle befinden immer unten drunter aufgeführt werden - also auch die Währungen wo in Spalte E kein "OK" steht, nur deren Werte sollen nicht mitsummiert, so dass bei einer Währung die kein "OK" in Spalte E hat quasi dann eine Null in der Summierung steht.
Toll wär auch noch, wenn unter den einzelnen summierten Währungen eine Summe der absoluten Beträge
gezogen werden könnte.
Ich hoffe mein Problem jetzt besser beschrieben zu haben - zur besseren Verständlichkeit lade ich hier aber noch mal die Datei hoch.
https://www.herber.de/bbs/user/49063.xls
Wäre toll wenn du mir noch mal helfen könntest...aus meiner Sicht, dürfte es dann auch (hoffentlich) das vorerst letzte mal gewesen sein :)
Also danke noch mal...
beste Grüße
Aexel
P.S.: Sorry, dass ich erst so spät geantwortet habe. Habs nicht früher gepackt wieder an meinen Rechner zu kommen und auf Arbeit funktioniert der Upload leider nicht!

Anzeige
AW: 1x helfen bitte...zum mitnehmen :)
16.01.2008 16:16:00
Peter
Hallo Aexel,
mein Makro kann ich wohl anpassen, aber das vom ransi eher nicht.


Option Explicit
Type Waehrg
   sWaehrg   As String
   dKauf     As Double
   dVerk     As Double
End Type
Public Sub NachWaehrung()
Dim lZeile       As Long
Dim lLetzte      As Long
Dim WaehrgTab()  As Waehrg
Dim iIndex       As Integer
Dim dSumme       As Double
   With Worksheets("Tabelle2")  ' <== Tabellenblattnamen ggf. anpassen !!!
      lLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
      ReDim WaehrgTab(1 To lLetzte)
      For lZeile = 2 To lLetzte
         For iIndex = 1 To UBound(WaehrgTab)
            If WaehrgTab(iIndex).sWaehrg = .Cells(lZeile, 2).Value Then
               If UCase(.Cells(lZeile, 5).Value) = "OK" Then
                  If .Cells(lZeile, 3).Value <> "" Then
                     If IsNumeric(.Cells(lZeile, 3).Value) Then
                        WaehrgTab(iIndex).dKauf = WaehrgTab(iIndex).dKauf + _
                           CDbl(.Cells(lZeile, 3).Value)
                     End If
                  End If
                  If .Cells(lZeile, 4).Value <> "" Then
                     If IsNumeric(.Cells(lZeile, 4).Value) Then
                        WaehrgTab(iIndex).dVerk = WaehrgTab(iIndex).dVerk + _
                           CDbl(.Cells(lZeile, 4).Value)
                     End If
                  End If
                  Exit For
                Else
                  Exit For
               End If
            ElseIf WaehrgTab(iIndex).sWaehrg = "" Then
               WaehrgTab(iIndex).sWaehrg = .Cells(lZeile, 2).Value
               If UCase(.Cells(lZeile, 5).Value) = "OK" Then
                  If .Cells(lZeile, 3).Value <> "" Then
                     If IsNumeric(.Cells(lZeile, 3).Value) Then
                        WaehrgTab(iIndex).dKauf = CDbl(.Cells(lZeile, 3).Value)
                     End If
                  End If
                  If .Cells(lZeile, 4).Value <> "" Then
                     If IsNumeric(.Cells(lZeile, 4).Value) Then
                        WaehrgTab(iIndex).dVerk = CDbl(.Cells(lZeile, 4).Value)
                     End If
                  End If
                  Exit For
                Else
                  Exit For
               End If
            End If
         Next iIndex
      Next lZeile
      lLetzte = lLetzte + 2
      For iIndex = 1 To UBound(WaehrgTab)
         If WaehrgTab(iIndex).sWaehrg <> "" Then
            lLetzte = lLetzte + 1
            .Cells(lLetzte, 2).Value = WaehrgTab(iIndex).sWaehrg
            .Cells(lLetzte, 3).Value = WaehrgTab(iIndex).dKauf
            .Cells(lLetzte, 4).Value = WaehrgTab(iIndex).dVerk
            dSumme = dSumme + Abs(WaehrgTab(iIndex).dVerk)
         End If
      Next iIndex
      .Cells(lLetzte + 1, 4).Value = dSumme
   End With
End Sub


Gruß Peter
Anzeige
AW: 1x helfen bitte...zum mitnehmen :)
16.01.2008 16:22:00
Aexel
Hallo Peter,
na dein Makro reicht mir ja schon vollkommen aus. Bei Ransi versteh ich ja fast nix :)
Toll danke dir...werds morgen mal ausprobieren und dir dann noch mal Feedback geben!
Bis dahin merci beaucoup.
Grüße
Aexel

AW: 1x helfen bitte...zum mitnehmen :)
16.01.2008 16:26:23
Peter
Hallo Aexel,
hier ransis Version allerdings ohne Summierung


Public Sub NachWaehrung_II()
Dim aTemp   As Variant
Dim lZeile  As Long
Dim rZelle  As Range
Dim Dict_1  As Variant
Dim Dict_2  As Variant
   aTemp = Sheets("Tabelle2").Range("A1").CurrentRegion
   Set rZelle = Sheets("Tabelle2").Cells(Rows.Count, 2).End(xlUp).Offset(3, 0)
   Set Dict_1 = CreateObject("Scripting.Dictionary")
   Set Dict_2 = CreateObject("Scripting.Dictionary")
   On Error Resume Next
   For lZeile = 2 To UBound(aTemp)
      If UCase(aTemp(lZeile, 5)) = "OK" Then
         Dict_1(aTemp(lZeile, 2)) = Dict_1(aTemp(lZeile, 2)) + aTemp(lZeile, 3)
         Dict_2(aTemp(lZeile, 2)) = Dict_2(aTemp(lZeile, 2)) + aTemp(lZeile, 4)
       Else
         Dict_1(aTemp(lZeile, 2)) = Dict_1(aTemp(lZeile, 2)) + 0
         Dict_2(aTemp(lZeile, 2)) = Dict_2(aTemp(lZeile, 2)) + 0
      End If
   Next lZeile
'    ausgeben
   rZelle.Resize(Dict_1.Count) = WorksheetFunction.Transpose(Dict_1.keys)
   rZelle.Offset(0, 1).Resize(Dict_1.Count) = WorksheetFunction.Transpose(Dict_1.Items)
   rZelle.Offset(0, 2).Resize(Dict_1.Count) = WorksheetFunction.Transpose(Dict_2.Items)
End Sub


Gruß Peter
AW: 1x helfen bitte...zum mitnehmen :)
16.01.2008 16:44:00
Aexel
Huhu...
so...Peter...hab dein Makro doch noch mal schnell auf die Hebebühne geschickt.
Ich muss schon sagen....excelicious....ist toll geworden und wird mir auch in der Zukunft
helfen denke ich. Erst hab ich zwar die Summe nicht finden können, aber..naja...weiße Schrift auf
weißem Hintergrund - nicht das allerklügste ist.
Wie dem auch sei..toll toll toll....werds morgen bei meiner neuen Datei dann gleich mal anwenden und
dir dann Bescheid geben ob sich dieses Thema, dieser Beitrag erledigt hat.
Einen schönen Abend noch wünscht ein fröhlicher...
Aexel

AW: 1x helfen bitte...zum mitnehmen :)
17.01.2008 14:08:00
Aexel
Joa Peter...
ich sach mal so. Das ist doch Sahne-Arbeit!! Jetzt ist die allmorgentliche Routine auch schnell vorbei...eins-zwei-fix. Sehr schön. Es gab zwar noch hier und da Probleme, die stehen aber nicht in Verbindung mit deinem Makro.
Super toll, dass mir hier geholfen werden konnte. Natürlich auch danke an die anderen "Ratschläger".
Na dann...man schreibt sich!!
Fröhliche Grüße vom
EinProblemWeniger-Aexel

AW: 1x helfen bitte...zum mitnehmen :)
17.01.2008 17:37:35
Peter
Hallo Aexel,
dann frohes Verrichten mit der Anwendung.
Was machst du denn nun mit der gewonnenen Zeit :-)
Gruß Peter

AW: 1x helfen bitte...zum mitnehmen :)
18.01.2008 09:55:32
Aexel
Hallo Peter,
was ich mit der Zeit mache....mmmhh gute Frag!?
Ahhhh....ist doch klar - ich werd die Zeit natürlicht nutzen um mich
in VBA reinzufriemeln und so andere händische Dinge automatisieren.
Und irgendwann...dann brauch ich gar nicht mehr händisch arbeiten...dann
komm ich auf Arbeit....schmeiß meine Makros an...und gut ist...hahaha
...ja so wirds ganz bestimmt!!
Grüüüüße
vom Aexel

AW: etwas kompakter
15.01.2008 15:41:00
Peter
Hallo Aexel,
hier ist ransis Lösung mit der OK-Abfrage


Public Sub Test()
Dim aTemp   As Variant
Dim lZeile  As Long
Dim rZelle  As Range
Dim Dict_1  As Variant
Dim Dict_2  As Variant
   aTemp = Sheets("Tabelle2").Range("A1").CurrentRegion
   Set rZelle = Sheets("Tabelle2").Cells(Rows.Count, 2).End(xlUp).Offset(3, 0)
   Set Dict_1 = CreateObject("Scripting.Dictionary")
   Set Dict_2 = CreateObject("Scripting.Dictionary")
   On Error Resume Next
   For lZeile = 2 To UBound(aTemp)
      If UCase(aTemp(lZeile, 5)) = "OK" Then
         Dict_1(aTemp(lZeile, 2)) = Dict_1(aTemp(lZeile, 2)) + aTemp(lZeile, 3)
         Dict_2(aTemp(lZeile, 2)) = Dict_2(aTemp(lZeile, 2)) + aTemp(lZeile, 4)
      End If
   Next lZeile
'    ausgeben
   rZelle.Resize(Dict_1.Count) = WorksheetFunction.Transpose(Dict_1.keys)
   rZelle.Offset(0, 1).Resize(Dict_1.Count) = WorksheetFunction.Transpose(Dict_1.Items)
   rZelle.Offset(0, 2).Resize(Dict_1.Count) = WorksheetFunction.Transpose(Dict_2.Items)
End Sub


Gruß Peter

168 Forumthreads zu ähnlichen Themen

Array-Formel in VBA-Code umwandeln?
Robert

Hallo,
ich bräuchte bitte eure Hilfe.
Hab folgende Formel...
Selection.FormulaArray = _
=IF(ROW(R[-107]C[-3])>COUNTA('1'!R5C[4]:R200C[4]),"""",INDEX('1'!R5C4:R200C4,SMALL(IF('1'!R5C[4]:R200C[4]<>"""",ROW(R1:R196),""""),ROW(R[-107]C[-3]))))"
Mein Problem ist, dass ic...
26.10.2008 10:56:28
Thread-ID: 1019326
13 Beiträge
Anzeige
Array in Tabelle schreiben
eres

Schönen Gruß in mein Lieblings-Forum,
ich lese sequentiell aus einer riesigen csv-Datei die ersten 50.000 Sätze in ein Array. Nach dem Einlesen möchte ich die Werte in ein sheet schreiben.
Dim HilfsArray(1 To 50000) As String
Dim i as long
Open Input_File For Input As #1
D...
08.04.2009 14:15:07
Thread-ID: 1067735
5 Beiträge
[VBA] Dreidimensionales Array in Tabellen ausgeben
Thomas

Hallo,
ich habe ein Problem mit der Ausgabe eines Arrays in eine Excel-Tabelle.
Ausgangspunkt ist folgender: With ThisWorkbook.Worksheets(1) .Cells(4, l).Resize(UBound(array, 1), UBound(array, 2)).Value = array End With
Das Array 'array' ist hierin zweidimensional, l wird durch...
06.10.2009 10:25:00
Thread-ID: 1107423
5 Beiträge
Anzeige
Array Formel summe wenn in VBA umwamdeln
t.wegmann@hengegroup.com

Hallo Liebes Forum,
ich habe ein Problem mit meiner Array-Formel:
=SUMME(WENN(('DATEN NEU'!$F$2:$F$25048=Frachten!$D4)*('DATEN NEU'!$N$2:$N$25048=Frachten!$F4) *('DATEN NEU'!$X$2:$X$25048=Frachten!H$2);'DATEN NEU'!$AB$2:$AB$25048))
Die Formel funktioniert gut, nur wenn ich die Date...
01.03.2010 09:54:52
Thread-ID: 1142293
2 Beiträge
ArraySumme von ABS Werten in VBA
ABS

Hallo Excel Freunde,
ich stehe gerade bei einer vermutlich banalen Sache auf der langen Leitung.
{=SUMME(ABS(A6:G6)) } Diese ArrayFormel bildet die Summe aller Einzelzellen von A6-G6 aus ihren individuellen ABS Werten.
Wie lautet diese Zeile in VBA, wenn testweise A6-G6 die Selectio...
10.03.2010 20:52:23
Thread-ID: 1144997
4 Beiträge
per VBA in MySQL-Tabelle schreiben
André

Moin,
ich hätte da mal wieder ein Problem.
Daten aus einer MySQL-Datenbank bekomme ich problemlos in meine Excel-Tabellen. Dies bekomme ich auch per VBA gesteuert. Hierzu habe ich eine ODBC-Verbindung erstellt. In der Excel-Tabelle erstelle ich dann eine neue Datenverbindung, die ich da...
20.04.2010 14:29:30
Thread-ID: 1152882
5 Beiträge
Array in VBA
PeTeR

Hallo VBA-Freaks,
ich habe 2 Spalten: Typ und Größe
Z.B.:
Typ Größe
A 1
B 3
A 4
C 2
A 5
B 1
C 4
Als Ergebnis hätte ich gerne folgendes (am liebsten per Makro in einem Array mit X*2 Feldern):
A: 1;4;5
B: 3;1<...
20.10.2010 13:56:57
Thread-ID: 1183205
7 Beiträge
array to range, range to array
Andi

Hallo,
Opa Helmut auf dem Fahrrad:
For i = 1 To UBound(arr)
Cells(1, i) = arr(i)
Next 'i
Raumschiff Enterprise
Range(Cells(1, 1), Cells(1, UBound(arr))) = arr
Ich favorisiere die Methode Raumschiff Enterprise, aber wenn ein arr Speicherplatz mit 1000 Zeichen belegt...
21.12.2010 18:50:18
Thread-ID: 1192391
12 Beiträge
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige
Archiv - Verwandte Themen
Forumthread
Beiträge
12
5
4
4
3
1
3
4
6
11
17
2
6
2
4
5
8
10
3
2
8
2
3
1
9