VBA: Daten nach Begriff durchsuchen und Werte kum.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Function BestimmeLetzteZeile(ByVal wks As Worksheet, ByVal s As Integer) As Long BestimmeLetzteZeile = wks.Cells(wks.Rows.Count, s).End(xlUp).Row End Function Function FindeWert(ByVal wks As Worksheet, ByVal strRange As String, ByVal strWert As String) _ As Range Set FindeWert = wks.Range(strRange).Find(strWert) End Function Function BestimmeLetzteSpalte(ByVal wks As Worksheet, ByVal z As Long) As Integer BestimmeLetzteSpalte = wks.Cells(z, 256).End(xlToLeft).Column End Function Function Beschleunigen(ByVal BGesetzt As Boolean) BGesetzt = Not BGesetzt With Application .ScreenUpdating = BGesetzt .AskToUpdateLinks = BGesetzt .EnableEvents = BGesetzt .Calculation = BGesetzt .DisplayAlerts = BGesetzt End With End Function Sub Start() Dim lastDaten As Long Dim wkb As Workbook Dim wksdaten As Worksheet Dim wksAusg As Worksheet Dim i As Long Dim j As Integer Dim rng As Range Dim ispalte As Integer Dim lzeile As Long Set wkb = ThisWorkbook Set wksdaten = wkb.Sheets("Daten") Set wksAusg = wkb.Sheets("Ausgabe") Beschleunigen True lastDaten = BestimmeLetzteZeile(wksdaten, 6) For i = 2 To lastDaten ispalte = 0 For j = 7 To 10 If InStr(1, wksdaten.Cells(i, 6).Value, wksAusg.Cells(1, j).Value, vbTextCompare) _ 0 Then ispalte = j Exit For End If Next j lzeile = 0 Set rng = FindeWert(wksAusg, "A:A", wksdaten.Cells(i, 21).Value) If Not rng Is Nothing Then lzeile = rng.Row End If If ispalte 0 And lzeile 0 Then wksAusg.Cells(lzeile, ispalte).Value = wksAusg.Cells(lzeile, ispalte).Value + _ wksdaten.Cells(i, 7).Value End If Next i Beschleunigen False End Sub

Hallo Jupp,
ja ist möglich, ;-)
der entscheidende Teil ist


For j = 7 To 10
If InStr(1, wksdaten.Cells(i, 6).Value, wksAusg.Cells(1, j).Value, vbTextCompare)  _
_
0 Then
ispalte = j
Exit For
End If
Next j

du könntest es sogar variable machen und auf einem Extrablatt eine tabelle anlegen mit deinen Begriffen und in der nächsten Spalte eine zuordnung der Spalte
zsb etwa
Auto 7
Fahrrad 8
U-Bahn 9
Flugzeug 10
irgend etwas anderes 6
dann brauchst du nciht mal die Reihenfolge gleich lassen.
mal angenommen dein Blatt heisst config und deine liste steht in A und B


Option Explicit
Function BestimmeLetzteZeile(ByVal wks As Worksheet, ByVal s As Integer) As Long
BestimmeLetzteZeile = wks.Cells(wks.Rows.Count, s).End(xlUp).Row
End Function
Function FindeWert(ByVal wks As Worksheet, ByVal strRange As String, ByVal strWert As String)   _
_
As Range
Set FindeWert = wks.Range(strRange).Find(strWert)
End Function
Function BestimmeLetzteSpalte(ByVal wks As Worksheet, ByVal z As Long) As Integer
BestimmeLetzteSpalte = wks.Cells(z, 256).End(xlToLeft).Column
End Function
Function Beschleunigen(ByVal BGesetzt As Boolean)
BGesetzt = Not BGesetzt
With Application
.ScreenUpdating = BGesetzt
.AskToUpdateLinks = BGesetzt
.EnableEvents = BGesetzt
.Calculation = BGesetzt
.DisplayAlerts = BGesetzt
End With
End Function
Sub Start()
Dim lastDaten As Long
dim lastConfig as Long
Dim wkb As Workbook
Dim wksdaten As Worksheet
Dim wksAusg As Worksheet
dim wksconf as Worksheet
Dim i As Long
Dim j As Integer
Dim rng As Range
Dim ispalte As Integer
Dim lzeile As Long
Set wkb = ThisWorkbook
Set wksdaten = wkb.Sheets("Daten")
Set wksAusg = wkb.Sheets("Ausgabe")
Set wksconf = wkb.Sheets("config")
Beschleunigen True
lastDaten = BestimmeLetzteZeile(wksdaten, 6)
lastConfig = BestimmeLetzteZeile(wksconf, 1)
For i = 2 To lastDaten
ispalte = 0
For j = 1 To lastConfig
If InStr(1, wksdaten.Cells(i, 6).Value, wksConf.Cells(j,1).Value, vbTextCompare)   _
_
0 Then
ispalte = wksConfig.Cells(j,2).value
Exit For
End If
Next j
lzeile = 0
Set rng = FindeWert(wksAusg, "A:A", wksdaten.Cells(i, 21).Value)
If Not rng Is Nothing Then
lzeile = rng.Row
End If
If ispalte  0 And lzeile  0 Then
wksAusg.Cells(lzeile, ispalte).Value = wksAusg.Cells(lzeile, ispalte).Value +  _
wksdaten.Cells(i, 7).Value
End If
Next i
Beschleunigen False
End Sub

ich hoffe, ich hab kein Syntax error drin, hab das jetzt hier eingegeben. Also neues Blatt config anlegen und dort in A deine Begriffe und in B die zugehörige Spalte anlegen.
Gruß
yummi

Sheets("Daten").Select Sheets("Daten").Columns("U:U").Select Selection.Copy Sheets("Ausgabe").Select Sheets("Ausgabe").Columns("A:A").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Range("$A$1:$A$14259").RemoveDuplicates Columns:=1, Header:= _ xlYes

Option Explicit Function BestimmeLetzteZeile(ByVal wks As Worksheet, ByVal s As Integer) As Long BestimmeLetzteZeile = wks.Cells(wks.Rows.Count, s).End(xlUp).Row End Function Function FindeWert(ByVal wks As Worksheet, ByVal strRange As String, ByVal strWert As String) _ _ _ As Range Set FindeWert = wks.Range(strRange).Find(strWert) End Function Function BestimmeLetzteSpalte(ByVal wks As Worksheet, ByVal z As Long) As Integer BestimmeLetzteSpalte = wks.Cells(z, 256).End(xlToLeft).Column End Function Function Beschleunigen(ByVal BGesetzt As Boolean) BGesetzt = Not BGesetzt With Application .ScreenUpdating = BGesetzt .AskToUpdateLinks = BGesetzt .EnableEvents = BGesetzt .Calculation = BGesetzt .DisplayAlerts = BGesetzt End With End Function Sub Start() Dim lastDaten As Long dim lastConfig as Long dim lastAusg as Long Dim wkb As Workbook Dim wksdaten As Worksheet Dim wksAusg As Worksheet dim wksconf as Worksheet Dim i As Long Dim j As Integer Dim rng As Range Dim ispalte As Integer Dim lzeile As Long Set wkb = ThisWorkbook Set wksdaten = wkb.Sheets("Daten") Set wksAusg = wkb.Sheets("Ausgabe") Set wksconf = wkb.Sheets("config") Beschleunigen True lastDaten = BestimmeLetzteZeile(wksdaten, 6) lastConfig = BestimmeLetzteZeile(wksconf, 1) lastAusgabe = BestimmeLetzteZeile(wksAusg, 1) For i = 2 To lastDaten ispalte = 0 For j = 1 To lastConfig If InStr(1, wksdaten.Cells(i, 6).Value, wksConf.Cells(j,1).Value, vbTextCompare) _ _ _ 0 Then ispalte = wksConfig.Cells(j,2).value Exit For End If Next j lzeile = 0 Set rng = FindeWert(wksAusg, "A:A", wksdaten.Cells(i, 21).Value) If Not rng Is Nothing Then lzeile = rng.Row else 'Wert nicht gefunden, also anhängen lzeile = lastAusgabe +1 wksAusgabe.Cells(lzeile, 1).value = wksdaten.Cells(i, 21).Value lastAusgabe = lastAusgabe +1 End If If ispalte 0 And lzeile 0 Then wksAusg.Cells(lzeile, ispalte).Value = wksAusg.Cells(lzeile, ispalte).Value + _ wksdaten.Cells(i, 7).Value End If Next i Beschleunigen False End Sub

Erneut Hallo,
vielen Dank für die Datei. Ich habe im Datenblatt einen Namen hinzugefügt und er wurde erfolgreich in die Liste der Namen im Ausgabe-Blatt übernommen.
Mir ist wohl aufgefallen, dass Änderungen im Daten-Blatt im Ausgabe-Tabellenblatt nur teilweise erfolgen.
Wenn ich in den Daten eine neue Zeile mit einem neuen Namen hinzufüge, wird dieser Name dem Ausgabe-Blatt hinzugefügt (wie es auch sein soll).
Wenn ich aber eine Zeile lösche oder den Namen überschreibe, bleibt sie bei erneuter Durchführung des Makros trotzdem im Ausgabe-Blatt drin.
Aber das könnte man ja dadurch bereinigen, indem das Makro das Ausgabe-Tabellenblatt zu Beginn der Durchführung komplett löscht.
Bezüglich der Spalte, welche die Differenz enthalten soll - anbei eine Beispiel-Datei die vielleicht verdeutlicht, was ich möchte:
https://www.herber.de/bbs/user/113964.xlsm
In Spalte F des Ausgabe-Blatts soll quasi der Wert stehen, der sich den Spalten G - J nicht zuordnen lässt.
Mal angenommen dass es im Daten-Blatt drei Zeilen gibt, welche den Namen"Fielmann" in Spalte U haben:

Beschreibung	Betrag	Name
Bla Auto	10	Fielmann
Bla Bla		15	Fielmann
Bla U-Bahn	5	Fielmann

Dann müsste nach Durchführung des Makros im Ausgabe-Blatt die Zeile mit dem Namen "Fielmann" folgendermaßen aussehen:

Name		Differenz	Auto	Fahrrad	U-Bahn	Flugzeug
Fielmann	15		10		5

Wenn man sich alle Werte der Zeile ansieht, erhält man für "Fielmann" also 30, den Gesamtwert für diesen Namen.
Ich hoffe es ist verständlich. Ich habe noch Kommentare in die Beispiel-Datei eingefügt.
Schönen Abend wünsche ich noch
Jupp

Beliebteste Forumthreads (12 Monate)

VBA: Daten nach Begriff durchsuchen und Werte kum.

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

325 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA: Daten nach Begriff durchsuchen und Werte kum.

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

325 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread