Liste filtern,Filterinhalt in neue Datei kopieren

Hallo zusammen,
ich bin neu hier im Forum. Ich hätte ein ANliegen.
Es geht um das Erstellen eines Standarddokumentes. Und zwar um ein sogenanntes Preisblatt. Ich will nach einem Lastenheft ein Preisblatt erstellen und dann an die verschiedene Lieferanten schicken. Nachdem die Lieferanten ihre Zahlen eingetragen haben, kann ich die einzelnen Spaltenbereich in ein neues Excel-File kopieren und vergleichen.
Nun zum Problem:
In diesem Preisblatt gibt es Punkte, die sind immer gleich, z.b 1.Projektierung, 1.1 1.2; usw.
dann gibt es Punkte, wie z.b. Optionen. Dieser Punkt varriert natürlich je ANlagenanschaffung.
Nun möchte ich eine Excelliste erstellen, die alle Punkte beinhaltet. Ich will durch "Häkchen setzen" meine benötigten Punkte auswählen, dann nach Häkchen filtern und dann die ausgewählten Punkte in einer neuen Datei öffnen. Dann kann ich sozusagen diese Datei speichern und habe mein preisblatt.
Das ganze hört sich sehr umfangreich an und mir fehlen dazu einfach die Kenntnisse und die Erfahrung. Die Suchfunktion habe ich verwendet, bin aber nicht auf eine Lösung gestoßen....gibt es sowas in ähnlicher Form?
Wäre super, wenn mir jmd helfen könnte!
Vielen Dank schon mal

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

'Erstell unter Excel 2010 'Code in einem allgemeinen Modul Sub Filter_plus_Copy() Dim wksAlle As Worksheet Dim wksListe As Worksheet Dim Zeile_L As Long Const Zeile_Titel As Long = 1 'Zeile mit den Spaltentitel im Blatt mit allen Punkten Const Spalte_X As Long = 10 ' Spalte J - Spalte in der die zu filternden Zeilen _ mit x oder anders markiert werden.. Set wksAlle = ActiveWorkbook.Worksheets("AllePunkte") 'Tabellenblatt mit allen Punkten Set wksListe = ActiveWorkbook.Worksheets("Preisliste") 'Musterblatt mit allen _ Seitenformatierungen wksListe.Copy Set wksListe = ActiveSheet With wksAlle If .AutoFilterMode = True Then If .FilterMode = True Then .ShowAllData End If .AutoFilterMode = False End If Zeile_L = .Cells(.Rows.Count, Spalte_X).End(xlUp).Row .Range(.Cells(Zeile_Titel, Spalte_X), .Cells(Zeile_L, Spalte_X)).AutoFilter _ Field:=1, Criteria1:="" .Range(.Cells(Zeile_Titel, 1), .Cells(Zeile_L, Spalte_X - 1)).Copy wksListe.Cells(4, 1) .ShowAllData .AutoFilterMode = False End With End Sub

'Erstell unter Excel 2010 'Code in einem allgemeinen Modul Sub Copy_plus_Filtern2() Dim wksListe As Worksheet Dim Zeile As Long, Zeile_L As Long Dim rng As Range Const Zeile_Titel As Long = 1 'Zeile mit den Spaltentitel im Blatt mit allen Punkten Const Spalte_X As Long = 10 ' Spalte J - Spalte in der die zu filternden Zeilen _ mit x oder anders markiert werden.. ActiveWorkbook.Worksheets("AllePunkte").Copy 'Tabellenblatt mit allen Punkten Set wksListe = ActiveSheet With wksListe .Name = "Preisliste" 'letzte Zeile mit Daten ermitteln Set rng = .Cells.Find(What:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _ lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious) If rng Is Nothing Then Exit Sub Else Zeile_L = rng.Row 'leere Zellen in der Markierungspalte suchen und ganze Zeilen löschen With .Range(.Cells(Zeile_Titel + 1, Spalte_X), .Cells(Zeile_L, Spalte_X)) If Application.WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlShiftUp End If End With 'Spalte mit Markierungen löschen .Columns(Spalte_X).Delete End With End Sub

Hallo Darius,
verwende für alle Summen und Zwischensummen die Funktion TEILERGEBNIS und gib immer Zellbereiche und nie Einzelzellen an.
Beispiel:

Position	Feld02	Anzahl	Einzelpreis	Gesamt
1		Text001			=TEILERGEBNIS(9;E10:E16)
1.1		Text002			=TEILERGEBNIS(9;E11:E12)
1.1.1		Text003	2	300	=C11*D11
1.1.2		Text004	5	100	=C12*D12
1.2		Text005			=TEILERGEBNIS(9;E14:E16)
1.2.1		Text006	1	120	=C14*D14
1.2.2		Text007	1	222	=C15*D15
1.2.3		Text008	1	132	=C16*D16
2		Text009			=TEILERGEBNIS(9;E18:E22)
2.1		Text010	1	567	=C18*D18
2.2		Text011			=TEILERGEBNIS(9;E20:E22)
2.2.1		Text012	2	123	=C20*D20
2.2.2		Text013	2	321	=C21*D21
2.2.3		Text014			=C22*D22
3		Text015	1	1234	=C23*D23
Summe					=TEILERGEBNIS(9;E9:E24)

Die Positionsnummern kann man nur neu generieren per Makro.
Ich hab es mal in das Makro eingebaut. Das ist jetzt komplizierter als alles vorherige.
Gruß
Franz

Sub Copy_plus_Filtern_3()
Dim wksListe As Worksheet
Dim Zeile As Long, Zeile_L As Long
Dim rng As Range
Const Zeile_Titel As Long = 8 'Zeile mit den Spaltentitel im Blatt mit allen Punkten
Const Spalte_X As Long = 10 ' Spalte J - Spalte in der die zu filternden Zeilen _
mit x oder anders markiert werden..
ActiveWorkbook.Worksheets("AllePunkte").Copy 'Tabellenblatt mit allen Punkten
Set wksListe = ActiveSheet
With wksListe
.Name = "Preisliste"
'letzte Zeile mit Daten ermitteln
Set rng = .Cells.Find(What:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rng Is Nothing Then Exit Sub Else Zeile_L = rng.Row
'leere Zellen in der Markierungspalte suchen und ganze Zeilen löschen
With .Range(.Cells(Zeile_Titel + 1, Spalte_X), .Cells(Zeile_L, Spalte_X))
If Application.WorksheetFunction.CountBlank(.Cells) > 0 Then
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlShiftUp
End If
End With
.Columns(Spalte_X).Delete
'Positionen neu nummerieren in Spalte 1 (A)
Dim intNr(1 To 4) As Integer, strPos(1 To 4) As String
Dim intStufe As Integer, intI As Integer, strText As String
'letzte Zeile mit Daten ermitteln
Set rng = .Cells.Find(What:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rng Is Nothing Then Exit Sub Else Zeile_L = rng.Row
For Zeile = Zeile_Titel + 1 To Zeile_L
With .Cells(Zeile, 1)         '1 anpassen, wenn Pos.-Nr. nicht in Spalte A
If IsNumeric(Left(.Text, 1)) Then
'Stufe aus Anzahl "." in Positionsnummer ermitteln
intStufe = Len(.Text) - Len(VBA.Replace(.Text, ".", "")) + 1
intNr(intStufe) = intNr(intStufe) + 1
Select Case intStufe
Case 1
strPos(intStufe) = "'" & Format(intNr(intStufe), "0")
Case Else
strPos(intStufe) = "." & Format(intNr(intStufe), "0")
End Select
For intI = intStufe + 1 To UBound(intNr)
strPos(intI) = ""
intNr(intI) = 0
Next
strText = ""
For intI = 1 To UBound(intNr)
strText = strText & strPos(intI)
Next
.Value = strText
End If
End With
Next
End With
End Sub

'Code unter diese Arbeitsmappe Private Sub Workbook_BeforeClose(Cancel As Boolean) 'beim Schliessen der Datei wird der Satus automatisch auf gespeichert gesetzt 'Datei wird nach Änderungen ohne Sicherheitsabfrage geschlossen Me.Saved = True End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) 'Der Speichern unter Dialog wird nicht angezeigt, sondern nur ein Hinweis 'gespeichert wird nur wenn in Message-Box ein korrektes Kennwort eingegeben wird. Dim varEingabe If SaveAsUI = True Then MsgBox "Datei darf nur mit Kennwort gespeichert werden" & vbLf _ & """Speichern unter"" nicht möglich", vbOKOnly, _ "Datei Speichern Unter" Cancel = True Else varEingabe = InputBox("Kennwort zum Speichern", "Speichern Datei") If varEingabe = "" Or varEingabe = False Then Cancel = True Else If varEingabe "Test" Then 'Prüfung eingegebenes Kennwort Cancel = True MsgBox "Kennwort ist falsch", vbOKOnly, "Datei Speichern - Kennworteingabe" End If End If End If End Sub

Beliebteste Forumthreads (12 Monate)

Liste filtern,Filterinhalt in neue Datei kopieren

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Liste filtern,Filterinhalt in neue Datei kopieren

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread