Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
900to904
900to904
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Summe gleiche artikel mit menge VBA

Forumthread: Summe gleiche artikel mit menge VBA

Summe gleiche artikel mit menge VBA
25.08.2007 14:40:45
Karel
Halle forum,
möchte gerne von tabelle1 daten artikel und menge übertragen nach tabelle2 ohne Duplikaten und mit gesamtsumme je Artikel die >0 sind. Daten in tabelle 2 untereinander.
Tabelle1
Artikel--- Bestand
1111-------20
1130------- 5
1111-------30
1112------- 0
1114-------10
Tabele2
Artikel-----Bestand
1111------- 50
1130-------- 5
1114-------10
Danke Karel

Anzeige

16
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Summe gleiche artikel mit menge VBA
25.08.2007 16:53:35
Renee
Mazwara Karel,
Über Daten - Filter - Spezialfilter kopierst Du die Spalte A ohne Duplikate nach Tabellenblatt 2
Dann setzt Du in Spalte B die Formel
=SUMMEWENN(Tabelle1!A:A;A2;(Tabelle1!B:B))(


und fertig...
Greetz Renee

AW: Summe gleiche artikel mit menge VBA
25.08.2007 16:53:00
nighty
hi karel :-)
wie gewuenscht :-))
gruss nighty
sollte es zu langsam sein, so koennte man ereignisse noch ausschalten
Option Explicit

Sub kopie()
Dim zeile As Long, zaehler0 As Long, zaehler1 As Long
Worksheets("Tabelle1").Select
zeile = Cells(Rows.Count, 1).End(xlUp).Row
ReDim matrix(zeile, 2) As Variant
matrix() = Range("A1:B" & zeile)
For zaehler0 = 2 To zeile
For zaehler1 = zaehler0 + 1 To zeile
If matrix(zaehler0, 1) = matrix(zaehler1, 1) Then
matrix(zaehler1, 1) = ""
matrix(zaehler0, 2) = matrix(zaehler0, 2) + matrix(zaehler1, 2)
matrix(zaehler1, 2) = ""
End If
Next zaehler1
Next zaehler0
Worksheets("Tabelle2").Select
Range("A1:B" & zeile) = matrix()
Columns("A:B").AutoFilter Field:=1, Criteria1:="="
Rows("2:" & Rows.Count).Delete Shift:=xlUp
Columns("A:B").AutoFilter
End Sub


Anzeige
AW: Summe gleiche artikel mit menge VBA
25.08.2007 17:02:14
Josef
Hallo Karel,
vieleicht genügt eine Formellösung.
Tabelle2

 ABC
1ArtikelBestand 
2111150 
311120 
4111410 
511305 
6   
7   

Formeln der Tabelle
ZelleFormel
A2=MIN(Tabelle1!A2:A30)
B2=WENN(A2<>"";SUMMEWENN(Tabelle1!$A$2:$A$30;A2;Tabelle1!$B$2:$B$30); "")
A3{=WENN(ANZAHL(Tabelle1!$A$2:$A$30)>ZEILE(A2); MIN(WENN(Tabelle1!$A$2:$A$30>A2;Tabelle1!$A$2:$A$30)); "")}
B3=WENN(A3<>"";SUMMEWENN(Tabelle1!$A$2:$A$30;A3;Tabelle1!$B$2:$B$30); "")
Enthält Matrixformel:
Umrandende { } nicht miteingeben,
sondern Formel mit STRG+SHIFT+RETURN abschließen!
Matrix verstehen


Tabelle1

 ABC
1ArtikelBestand 
2111120 
311305 
4111130 
511120 
6111410 
7   
8   
9   
10   
11   
12   
13   
Excel Tabellen im Web darstellen  Excel Jeanie HTML
Gruß Sepp

Anzeige
AW: Summe gleiche artikel mit menge VBA
25.08.2007 17:45:00
Christian
Hallo Karel,
mit Formel, aber auch mit Hilfspalte:
Tabelle1

 ABC
11111201
2113052
3111130 
411120 
51114103
6   
7   
8   
9   
10   

Formeln der Tabelle
ZelleFormel
C1=ZEILE()
C2=WENN(ODER(B2=0;A2="";ZÄHLENWENN($A$1:A2;A2)>1); "";MAX(C$1:C1)+1)


Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Tabelle2

 AB
1111150
211305
3111410
4  
5  
6  
7  

Formeln der Tabelle
ZelleFormel
A1=WENN(ZEILE()>MAX(Tabelle1!C:C); "";INDEX(Tabelle1!A:A;VERGLEICH(ZEILE(); Tabelle1!C:C;0)))
B1=WENN(A1="";"";SUMMENPRODUKT((Tabelle1!$A$1:$A$1000=A1)*Tabelle1!$B$1:$B$1000))


Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
MfG Christian

Anzeige
AW: Summe gleiche artikel mit menge VBA
25.08.2007 17:56:02
nighty
hi all :-)
so gefaellt mir das :-))
jetzt wuerde noch eine makroloesung mit dictionary objekt fehlen :-)))
gruss nighty

AW: Summe gleiche artikel mit menge VBA
25.08.2007 19:03:38
Karel
Hi Nighty,
Danke an alle ander aber formel hatte ich schon.
Makro lauft, gut gelesen VBA:-) danke habe es grade getest mit 40.000 daten, makro lauft dan sehr Langsam und in Tabelle2 sollte nur Artikel mit menge ubertragen werden mit Bestand grosser dan NUL (>0)
Danke Karel

Anzeige
AW: Summe gleiche artikel mit menge VBA
25.08.2007 20:54:57
Josef
Hallo Karel,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Summe_Liste()
Dim wsS As Worksheet, wsT As Worksheet
Dim vTmp1() As Variant, vTmp2() As Variant
Dim rngA As Range, rngB As Range
Dim lngC As Long, lngI As Long, dblS As Double

Set wsS = Sheets("Tabelle1") 'Quelltabelle
Set wsT = Sheets("Tabelle2") 'Zieltabelle

Set rngA = wsS.Range("A2:A" & wsS.Cells(Rows.Count, 1).End(xlUp).Row)
Set rngB = wsS.Range("B2:B" & wsS.Cells(Rows.Count, 1).End(xlUp).Row)

Redim vTmp1(rngA.Rows.Count + 1)
Redim vTmp2(rngA.Rows.Count + 1)

wsT.Range("A2:B" & Rows.Count).ClearContents

For lngC = 1 To rngA.Rows.Count + 1
    If IsError(Application.Match(rngA.Cells(lngC, 1), vTmp1, 0)) Then
        dblS = Application.SumIf(rngA, rngA.Cells(lngC, 1), rngB)
        If dblS <> 0 Then
            vTmp1(lngI) = rngA.Cells(lngC, 1)
            vTmp2(lngI) = dblS
            lngI = lngI + 1
        End If
    End If
Next

If lngI > 0 Then
    wsT.Range("A2:A" & lngI + 2) = Application.Transpose(vTmp1)
    wsT.Range("B2:B" & lngI + 2) = Application.Transpose(vTmp2)
End If


Set rngA = Nothing
Set rngB = Nothing
Set wsS = Nothing
Set wsT = Nothing

End Sub

Gruß Sepp

Anzeige
AW: Summe gleiche artikel mit menge VBA
25.08.2007 20:23:54
nighty
hi karel :-)
so vielleicht besser :-))
schneller waere noch ein dictionary makro,doch da bin noch zu unerfahren leider :-(
gruss nighty
Option Explicit
Sub kopie()
Call EventsOff
Dim zeile As Long, zaehler0 As Long, zaehler1 As Long
Worksheets("Tabelle1").Select
zeile = Cells(Rows.Count, 1).End(xlUp).Row
ReDim matrix(zeile, 2) As Variant
matrix() = Range("A1:B" & zeile)
For zaehler0 = 2 To zeile
For zaehler1 = zaehler0 + 1 To zeile
If matrix(zaehler0, 1) = matrix(zaehler1, 1) Then
matrix(zaehler1, 1) = ""
matrix(zaehler0, 2) = matrix(zaehler0, 2) + matrix(zaehler1, 2)
matrix(zaehler1, 2) = ""
End If
Next zaehler1
If matrix(zaehler0, 2) = 0 Then
matrix(zaehler0, 1) = ""
matrix(zaehler0, 2) = ""
End If
Next zaehler0
With Worksheets("Tabelle2")
.Range("A1:B" & zeile) = matrix()
.Columns("A:B").AutoFilter Field:=1, Criteria1:="="
.Rows("2:" & Rows.Count).Delete Shift:=xlUp
.Columns("A:B").AutoFilter
End With
Call EventsOn
End Sub 



Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub




Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub


Anzeige
AW: Summe gleiche artikel mit menge VBA
25.08.2007 23:29:39
Gerd
Hallo,
nur weil ich ebenfalls schon gebastelt hatte.

Sub test()
Dim vnt1(), vnt2(), vnt3(), i As Long, j As Long, lngIndex As Long
With Worksheets("Tabelle1")
vnt1 = .Range("A2:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim vnt2(1 To .Cells(Rows.Count, 1).End(xlUp).Row - 1)
ReDim vnt3(1 To .Cells(Rows.Count, 1).End(xlUp).Row - 1)
End With
For i = 1 To UBound(vnt1, 1)
lngIndex = 0
On Error Resume Next
lngIndex = WorksheetFunction.Match(CLng(vnt1(i, 1)), vnt2, 0)
On Error GoTo 0
If vnt1(i, 2)  0 Then
If lngIndex = 0 Then
j = j + 1
vnt2(j) = vnt1(i, 1)
vnt3(j) = vnt1(i, 2)
Else
vnt3(lngIndex) = vnt3(lngIndex) + vnt1(i, 2)
End If
End If
Next
With Worksheets("Tabelle2")
.Columns("A:B").ClearContents
.Range("A2:A" & (UBound(vnt2) + 1)).Value = WorksheetFunction.Transpose(vnt2)
.Range("B2:B" & (UBound(vnt3) + 1)).Value = WorksheetFunction.Transpose(vnt3)
.Range("A1").Value = "Artikel"
.Range("B1").Value = "Bestand"
End With
End Sub


Grüße Gerd

Anzeige
AW: Summe gleiche artikel mit menge VBA
26.08.2007 11:31:10
nighty
hi all :-)
welches makro ist nun am schnellsten :-))
konnte keine zeitmessung durchduehren mein excel 2000 verabschiedet sich bei nachgebauten 60 000 oder auch 30 000 zeilen :-(
gruss nighty

AW: Summe gleiche artikel mit menge VBA
26.08.2007 12:33:20
Karel
Hallo,
habe getestet, und habe bei Sepp und Gerd gleiche Laufzeitfehler 13 ?
Hallo Sepp
Laufzeitfehler 13
If IsError(Application.Match(rngA.Cells(lngC, 1), vTmp1, 0)) Then
Hallo Gerd
Laufzeitfehler 13
.Range("A2:A" & (UBound(vnt2) + 1)).Value = WorksheetFunction.Transpose(vnt2)
Hallo Nighty,
Haben makro unterbrochen lauft und lauft und lauft :)
Gruss Karel

Anzeige
AW: Summe gleiche artikel mit menge VBA
26.08.2007 12:49:08
Gerd
Hallo Karel,
hast Du leere Zellen "dazwischen" ?
Gruß Gerd

AW: Summe gleiche artikel mit menge VBA
26.08.2007 21:49:23
Karel
Hallo Gerd,
es gibt kein leerzelle, habe versucht fehler in datensätze einzurahmen in schritte von 1000 und nachher in 100, endresultat ist das bis zeile 5462 alles lauft und wenn zeile 5463 mit daten gefullt werd, dann tritt sofort gleiche Laufzeitfehler auf, habe keine idee warum.
Grusse
Karel

Anzeige
AW: Summe gleiche artikel mit menge VBA
26.08.2007 22:29:45
Gerd
Hallo Karel,
was steht in Spalte A u. Spalte B der Zeile 5463 u. welches (Zellen-)Zahlenformat haben diese Zellen?
Gruß Gerd

AW: Summe gleiche artikel mit menge VBA
28.08.2007 18:51:00
Karel
Hallo Gerd,
Gute nachrichten
konnte heute wieder testen, fehler scheint bei meine computer (Excel Version?) zu liegen. Auf eine ander compter lauft alle einwandfrei.
Habe noch zwei fragen.
- wo kan ich in dein makro, die wert einstellen um bei dedarf auch noch die nulwerte zu übertragen.
- kan men dein makro auch auf mehere tabellenblätter erweiteren Z.b. Tab1, Tab2, Tab3, Tab4 etc und alle daten übertragen auf Tabelenblat gesamt_Bestand, wegen grosse datenmengen.
danke in jedenfall für deine saubere lösung (von alle Makros am Schnellste)
viele grusse
Karel

Anzeige
AW: Summe gleiche artikel mit menge VBA
28.08.2007 23:01:58
Gerd
Hallo Karel,
der fachlich interessantere Code ist derjenige von Sepp.
Nullwerte in Spalte B mitübertragen. Da muss eine Bedingung raus. 

Sub test()
Dim vnt1(), vnt2(), vnt3(), i As Long, j As Long, lngIndex As Long
With Worksheets("Tabelle1")
vnt1 = .Range("A2:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim vnt2(1 To .Cells(Rows.Count, 1).End(xlUp).Row - 1)
ReDim vnt3(1 To .Cells(Rows.Count, 1).End(xlUp).Row - 1)
End With
For i = 1 To UBound(vnt1, 1)
lngIndex = 0
On Error Resume Next
lngIndex = WorksheetFunction.Match(CLng(vnt1(i, 1)), vnt2, 0)
On Error GoTo 0
'If vnt1(i, 2)  0 Then  - weglassen!
If lngIndex = 0 Then
j = j + 1
vnt2(j) = vnt1(i, 1)
vnt3(j) = vnt1(i, 2)
Else
vnt3(lngIndex) = vnt3(lngIndex) + vnt1(i, 2)
'End If  -- weglassen!
End If
Next
With Worksheets("Tabelle2")
.Columns("A:B").ClearContents
.Range("A2:A" & (UBound(vnt2) + 1)).Value = WorksheetFunction.Transpose(vnt2)
.Range("B2:B" & (UBound(vnt3) + 1)).Value = WorksheetFunction.Transpose(vnt3)
.Range("A1").Value = "Artikel"
.Range("B1").Value = "Bestand"
End With
End Sub


Aus mehreren Tabellen einlesen - mal sehen, wäre noch auszuknobeln.
(Die Obergrenze der Datensätze insgesamt dürfte bei Nummer letzte Zeile -1= 65535 liegen.)
Gruß Gerd

Anzeige
;

Beliebteste Forumthreads (12 Monate)

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