VBA: Daten nach Begriff durchsuchen und Werte kum.

Josef · 2017-06-01T11:10:54+00:00

Hallo allerseits, ich stehe vor einer Herausforderung, welche ich gerne mit einem Excel-Makro lösen möchte. Ich bin was VBA angeht noch ein Rookie und hoffe daher, hier Hilfe zu finden. Die Beispieldatei gibt euch einen Überblick, über das was ich möchte: https://www.herber.de/bbs/user/113948.xlsx Im Tabellenblatt "Daten" findet ihr die Rohdaten (wichtig sind eigentlich nur drei Spalten, weswegen alle anderen Spalten Füller sind). In diesem Blatt sind Buchungsdaten vorhanden. Nun möchte ich gerne dass ein Makro das Blatt Zeile für Zeile durchgeht und in Spalte F ("Beschreibung") nach bestimmten Begriffen Ausschau hält. Wenn es einen der gesuchtne Begriffe findet, soll es den dazugehörigen Betrag (Spalte G) nehmen und kumuliert in das Tabellenblatt "Ausgabe" in die richtige Spalte und in die richtige Zeile (also mit dem passenden Namen) eintragen. Leider sind die Namen weder im Daten-Tabellenblatt noch im Ausgabe-Tabellenblatt in irgendeiner Form sortiert. Ich hoffe diese Erklärung ist ausreichend. Falls aber noch Fragen bestehen - immer her damit. Beste Grüße Jupp

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

Hallo Jupp,
wenn der Name nciht gefunden wird in Ausgabe, dann unten dran hängen:


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

Jetzt wird der Wert bei nciht gefunden ergänzt ;-)
Gruß
yummi

VBA: Daten nach Begriff durchsuchen und Werte kum.

Forumthread: VBA: Daten nach Begriff durchsuchen und Werte kum.

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

VBA: Daten nach Begriff durchsuchen und Werte kum.

Forumthread: VBA: Daten nach Begriff durchsuchen und Werte kum.

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread