PDA

Vollständige Version anzeigen : Tabelle durchsuchen und gezielt ergebnisse verwenden


nicolino
24.07.2012, 09:05
Schönen guten Morgen,

ich brauche dringend Hilfe.

Ich habe eine Tabelle mit Namen, Abt., Einlagerungsdatum usw. (kleine Lagertabelle).
Meine Aufgabe ist folgende: Es sollen automatisch Listen erstellt werden. Für Jede Abteilung eine Liste. Dazu habe ich bereits für jede Abteilung ein Tabellenblatt (Name: "Abteilung 100" usw.)angelegt in welchen die Listen generiert werden sollen. Dabei sollen aber nur alle Einträge in den Listen erscheinen, welche älter bzw. gleich alt dem Datum (Jahreszahl) sind, welches ich in eine Zelle eingeben will.

Im Augenblick drücke ich einen Button, der durchsucht die Tabelle, findet alle Einträge zu dem Suchwort und löscht genau die mit der eingegebenen Jahreszahl.

Ich muss dazu sagen, ich habe alle VBA Codes aus Foren und bastel sie mir zusammen. Ich habe nicht wirklich eine Ahnung was da steht. Kann mir bitte jemand helfen.

wenn mir jemand mit der automatisierung helfen könnte und meinen Code so ändert, dass er alle jüngeren eingaben löscht wäre mir schon sehr geholfen.

Vielen Vielen Dank! Nicolino

der Aktuelle code:
Option Explicit


Public Sub Suchfunktion_Abt()
Dim Findmy As Range 'myFind => Findmy
Dim Calcstd As Long 'stdCalc => Calcstd
Dim Sheeto As Worksheet 'oSheet => Sheeto
Dim Datestr As String 'strDate => Datestr
Dim LastAddressmy As String 'myLastAdress => LastAdressmy

Calcstd = Application.Calculation
On Error GoTo ErrH

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With



If Not Sheets("Abteilung 2").TextBox1.Value = "" Then
Set Sheeto = Sheets("Abteilung 2")
Datestr = Sheets("Abteilung 2").TextBox1


With Sheets("Auswertung Datum 2")
Set Findmy = .Cells.Find(Datestr, LookIn:=xlValues, LookAt:=xlWhole)
If Not Findmy Is Nothing Then
LastAddressmy = Findmy.Address
Do
.Range(.Cells(Findmy.Row, 1), .Cells(Findmy.Row, 18)).Copy
Sheeto.Cells(IIf(Sheeto.Cells(1, 8) = "", 1, _
Sheeto.Cells(Rows.Count, 1).End(xlUp).Row + 1), 1).PasteSpecial xlPasteValues
Set Findmy = .Cells.FindNext(Findmy)
Loop Until Findmy.Address = LastAddressmy '
Sheeto.Cells.EntireColumn.AutoFit
End If
End With

ErrH:
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = False
.Calculation = Calcstd
End With

End If

If Not Sheets("Abteilung 2").TextBox2.Value = "" Then
Set Sheeto = Sheets("Abteilung 2")
Datestr = Sheets("Abteilung 2").TextBox2

With Sheets("Abteilung 2")
Set Findmy = .Cells.Find(Datestr, LookIn:=xlValues, LookAt:=xlWhole)
If Not Findmy Is Nothing Then
LastAddressmy = Findmy.Address
Do
.Range(.Cells(Findmy.Row, 1), .Cells(Findmy.Row, 18)).Delete
Set Findmy = .Cells.FindNext(Findmy)
Loop Until Findmy.Address = LastAddressmy '
Sheeto.Cells.EntireColumn.AutoFit
End If
End With

'ErrH:
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = False
.Calculation = Calcstd
End With

End If

End Sub

Hasso
24.07.2012, 13:03
Hallo nicolino,

Mein gerne wiederholter Tipp: Das Hochladen einer Beispieldatei erhöht die Chance auf eine befriedigende Antwort ungemein!

Wenn du hier Code postest, benutze bitte die CODE-Tags, damit das Ganze lesbar wird.

nicolino
24.07.2012, 14:07
Hallo Hasso,

ich habe versucht ein Beispiel zu kopieren. Die Original-Datei ist über 9MB groß.
Auf Tabellenblatt4 habe ich noch mal mein Problem geschildert.

Vielen Dank für deine Hilfe!

Mit freundlichen Grüßen

Nicolino

Hasso
24.07.2012, 15:26
Hallo nicolino,

ich habe dir da mal was gestrickt.

Sieh dir mal an, ob das deinen Vorstellungen entspricht. Die Datumsauswahl habe ich noch nicht eingebaut, da bei manchen Projekten kein Datum vorhanden ist und man hier noch Fehler abfangen muss. Ich möchte erst einmal wissen, ob das so im Prinzip OK ist.

Option Explicit
Public Sub DatenÜbertragen()
Dim zeile As Integer
Dim spalte As Integer
Dim zelle As Range
Dim jahr As Integer
Dim abteilung As Integer

jahr = Worksheets("Tabelle4").Range("D3")
abteilung = Worksheets("Abteilung 100").Cells(1, 2)

zeile = 4
Worksheets("Abteilung 100").Range("A4:H" & Worksheets("Abteilung 100").UsedRange.Rows.Count).Clear
For Each zelle In Worksheets("Auswertung Datum 2").Range("G1:G" & Worksheets("Auswertung Datum 2").UsedRange.Rows.Count)
If Worksheets("Auswertung Datum 2").Cells(zelle.Row, 19) = abteilung Then
For spalte = 1 To 5
Worksheets("Abteilung 100").Cells(zeile, spalte) = Worksheets("Auswertung Datum 2").Cells(zelle.Row, spalte)
Next
Worksheets("Abteilung 100").Cells(zeile, 6) = Worksheets("Auswertung Datum 2").Cells(zelle.Row, 12)
Worksheets("Abteilung 100").Cells(zeile, 6).NumberFormat = "m/d/yyyy"
Worksheets("Abteilung 100").Cells(zeile, 7) = Worksheets("Auswertung Datum 2").Cells(zelle.Row, 15)
Worksheets("Abteilung 100").Cells(zeile, 8) = Worksheets("Auswertung Datum 2").Cells(zelle.Row, 16)
zeile = zeile + 1
End If
Next zelle

End Sub


Beispielmappe anbei.

nicolino
24.07.2012, 15:50
Prinzip passt! :-)
Die Tabelle im "Tabellenblatt 100" müsste sich nur allein erstellen, ohne einen Button zu drücken, wenn das geht.
Wenn dir das helfen sollte, Einträge ohne Datum sollen einfach nicht beachtet werden.

Hab schon mal vielen Dank!

Mit freundlichen Grüßen
Nicolino

Hasso
24.07.2012, 16:23
Hallo nicolino,

Die Tabelle im "Tabellenblatt 100" müsste sich nur allein erstellen, ohne einen Button zu drücken.

ich habe es jetzt so geändert, dass die Füllung ausgelöst wird, wenn du eine Abteilung in dem Blatt Abteilung 100 eingibst oder das Blatt aktiviert wird.

nicolino
24.07.2012, 18:33
Vielen Vielen Dank Hasso. Das ist einfach super!!!!

Kannst du mir vieleicht noch ein Buch oder eine Seite empfehlen, wo ich schnell und effektiv was über VBA lernen kann?

Nochmals vielen vielen Dank!

Hasso
24.07.2012, 18:53
Hallo nicolino,

hier einige Links:

http://de.wikibooks.org/wiki/VBA_in_Excel
http://www.schmittis-page.de/excel/vba/vba.htm
http://www.xlam.ch/soscq/index.htm
http://www.herber.de/materialien/vbainexcel.zip
http://www.youtube.com/user/ITSeminare4You

Ich hoffe, das hilft dir weiter.

nicolino
25.07.2012, 10:23
Danke! Werd ich mir mal anschauen und lernen!

Noch mal Danke für deine Hilfe!