Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1272to1276
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro mit Spezielfilter

Makro mit Spezielfilter
Manu
Hallo an Alle,
ich sitze seit Tagen an einem Problem und komme mit meinen geringen VBA Kenntnissen nicht weiter.
Ich habe eine dynamische Tabelle mit 20 Spalten. In den Spalten R:W stehen Mitarbeiternamen. Der eines Mitarbeiters kann einmal in jeder Zeile in den R:W vorkommen. Z.b. steht "Herr Meier" in der Zelle R6, S7, T9 und W9
Jetzt möchte ich, daß die ganze Tabelle mit einer Schleife über einen Spezialfilter mit allen vorkommenden Namen in den Spalten R:W gefiltert wird und das Ergebnis pro Namen in eine neue Datei geschrieben wird.
Ich habe schon "tausend" Ansätze versucht, scheitere aber leider. Ich hoffe, es kann mir jemand helfen
Vielen Dank und Gruß
Manu
AW: Makro mit Spezielfilter
18.08.2012 15:25:40
Hajo_Zi
Hallo Manu,
Spezialfilter ist der falsche Ansatz, der ist dazu da um doppelte herrauszufischen
Was ist nun in Zeile 35 steht Herr Meier in Spalte R und Herr Schulz in Spalte W soll diese Zeile also 2x erscheinen? Bei Meier und Schulz?

AW: Makro mit Spezielfilter
18.08.2012 15:51:34
Manu
Hallo Hajo,
Ja, die Zeile soll dann sowohl in der Datei von Herr Meier, als auch in der Datei von Herr Schulz enthalten sein.
Gruß
Manu
AW: Makro mit Spezielfilter
18.08.2012 16:22:21
Hajo_Zi
Hallo Manu,
Option Explicit
Dim WbDatei As Workbook
Sub Teilen()
Dim LoI As Long
Dim LoJ As Long
Dim Bovorhanden As Boolean
Dim Loletzte As Long
Dim WsTabelle As Worksheet
Set WsTabelle = ActiveSheet
Loletzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For LoI = 1 To Loletzte
For LoJ = 18 To 23
If WsTabelle.Cells(LoI, LoJ)  "" Then
Bovorhanden = Vorhanden(WsTabelle.Cells(LoI, LoJ))
If Bovorhanden = False Then
Workbooks.Add
ActiveWorkbook.SaveAs Filename:= _
ThisWorkbook.Path & "\" & WsTabelle.Cells(LoI, LoJ) & ".xls", _
FileFormat:=xlExcel8
End If
With Workbooks(WsTabelle.Cells(LoI, LoJ) & ".xls").Worksheets(1)
WsTabelle.Rows(LoI).Copy .Rows(.UsedRange.SpecialCells(xlCellTypeLastCell). _
Row + 1)
End With
End If
Next LoJ
Next LoI
Set WsTabelle = Nothing
End Sub
Function Vorhanden(StName As String) As Boolean
Vorhanden = False
For Each WbDatei In Workbooks
If Left(WbDatei.Name, InStrRev(WbDatei.Name, ".") - 1) = StName Then
Vorhanden = True
End If
Next
End Function
Gruß Hajo
Anzeige
AW: Makro mit Spezielfilter
18.08.2012 16:32:53
Manu
Hallo Hajo,
ersmal Danke. Wenn ich das Makro starte, bekomme ich folgende Fehlermeldung:
Fehler beim Kompilieren: Variable nicht definiert:
Im Code wird folgendes gelb markiert: FileFormat:=xlExcel8
Ich benutze Excel2003 habe auf meinem Computer aber zusätzlich auch Excel2007 installiert. Ich weiß nicht, ob diese Information relevant ist.
Danke und LG
Manu
AW: Makro mit Spezielfilter
18.08.2012 16:36:38
Hajo_Zi
Hallo Manu,
ich habe kein 2003 aktiv. Lösche den Teil. Oder mal mit dem Makrorecorder aufzeichnen.
Gruß Hajo
AW: Makro mit Spezielfilter
18.08.2012 16:46:56
Manu
Hallo Hajo,
Ich bin begeistert - habe es gelöscht und es funktioniert :-)
Zwei Fragen hab ich noch:
1) Kann das Makro so umgeschrieben werden, daß die Überschriftzeile (Zeile 4) mit in den neuen Dateien steht und das Makro auch erst mit der Abfrage in Zeile 5 beginnt.
2) Können die einzelnen Dateien direkt gespeichert und geschlossen werden. Ich muß sonst unter Umständen ca. 300 Dateien manuell schließen.
Vielen, vielen ganz herzlichen Dank
Manu
Anzeige
AW: Makro mit Spezielfilter
18.08.2012 16:53:42
Hajo_Zi
Hallo Manu,
das ist jetzt ungetestet.
Option Explicit
Dim WbDatei As Workbook
Sub Teilen()
Dim LoI As Long
Dim LoJ As Long
Dim Bovorhanden As Boolean
Dim Loletzte As Long
Dim WsTabelle As Worksheet
Set WsTabelle = ActiveSheet
Loletzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For LoI = 5 To Loletzte
For LoJ = 18 To 23
If WsTabelle.Cells(LoI, LoJ)  "" Then
Bovorhanden = Vorhanden(WsTabelle.Cells(LoI, LoJ))
If Bovorhanden = False Then
Workbooks.Add
ActiveWorkbook.SaveAs Filename:= _
ThisWorkbook.Path & "\" & WsTabelle.Cells(LoI, LoJ) & ".xls", _
FileFormat:=xlNormal
WsTabelle.Rows(4).Copy ActiveWorkbook.Worksheets(1).Rows(1)
End If
With Workbooks(WsTabelle.Cells(LoI, LoJ) & ".xls").Worksheets(1)
WsTabelle.Rows(LoI).Copy .Rows(.UsedRange.SpecialCells(xlCellTypeLastCell). _
Row + 1)
End With
End If
Next LoJ
Next LoI
For Each WbDatei In Workbooks
If WbDatei.Name  ThisWorkbook.Name Then WbDatei.Close True
Next WbDatei
Set WsTabelle = Nothing
End Sub
Function Vorhanden(StName As String) As Boolean
Vorhanden = False
For Each WbDatei In Workbooks
If Left(WbDatei.Name, InStrRev(WbDatei.Name, ".") - 1) = StName Then
Vorhanden = True
End If
Next WbDatei
End Function
Gruß Hajo
Anzeige
Danke - Danke
18.08.2012 16:58:03
Manu
Hallo Hajo,
funktioniert perfekt :-)
Fühl Dich ganz toll gedrückt von mir.
Schönes Wochenende
Manuela
AW: Makro mit Spezielfilter
19.08.2012 16:55:17
Manu
Hallo Hajo,
ich hoffe Du kannst noch einmal öffnen. In den neu erzeugten Dateien sollen nur die Spalten A bis P zu sehen sein. Die Spalten Q-CE müssten also vor dem schließen gelöscht werden.
Habe es natürlich auch schon selbst versucht, bekomme es aber nicht hin.
Danke und Gruß
Manu
Noch eine Frage zum Makro
19.08.2012 16:56:48
Manu
Hallo Hajo,
ich hoffe Du kannst noch einmal öffnen. In den neu erzeugten Dateien sollen nur die Spalten A bis P zu sehen sein. Die Spalten Q-CE müssten also vor dem schließen gelöscht werden.
Habe es natürlich auch schon selbst versucht, bekomme es aber nicht hin.
Danke und Gruß
Manu
Anzeige
AW: Noch eine Frage zum Makro
19.08.2012 17:00:58
Hajo_Zi
Hallo Manu,
ungetestet.
Option Explicit
Dim WbDatei As Workbook
Sub Teilen()
Dim LoI As Long
Dim LoJ As Long
Dim Bovorhanden As Boolean
Dim loletzte As Long
Dim WsTabelle As Worksheet
Set WsTabelle = ActiveSheet
loletzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For LoI = 5 To loletzte
For LoJ = 18 To 23
If WsTabelle.Cells(LoI, LoJ)  "" Then
Bovorhanden = Vorhanden(WsTabelle.Cells(LoI, LoJ))
If Bovorhanden = False Then
Workbooks.Add
ActiveWorkbook.SaveAs Filename:= _
ThisWorkbook.Path & "\" & WsTabelle.Cells(LoI, LoJ) & ".xls", _
FileFormat:=xlNormal
WsTabelle.Rows(4).Copy ActiveWorkbook.Worksheets(1).Rows(1)
End If
With Workbooks(WsTabelle.Cells(LoI, LoJ) & ".xls").Worksheets(1)
WsTabelle.Rows(LoI).Copy .Rows(.UsedRange.SpecialCells(xlCellTypeLastCell). _
Row + 1)
End With
End If
Next LoJ
Next LoI
For Each WbDatei In Workbooks
If WbDatei.Name  ThisWorkbook.Name Then
WbDatei.Worksheets(1).Columns("Q:CE").Delete
WbDatei.Close True
End If
Next WbDatei
Set WsTabelle = Nothing
End Sub
Function Vorhanden(StName As String) As Boolean
Vorhanden = False
For Each WbDatei In Workbooks
If Left(WbDatei.Name, InStrRev(WbDatei.Name, ".") - 1) = StName Then
Vorhanden = True
End If
Next WbDatei
End Function
Gruß Hajo
Anzeige
AW: Noch eine Frage zum Makro
19.08.2012 17:07:07
Manu
Hallo Hajo,
wahnsinn - ich sitze stunden und komme nicht weiter und Du hilfst ein Sekunden.
Du bis Spitze. Erneut vielen Dank.
Manu
AW: Noch eine Frage zum Makro
19.08.2012 17:09:58
Hajo_Zi
Hallo Manu,
Du solltest bei dem Makro nur die Datei mit den Daten geöffnet haben. Da der Code in allen offenen Dateien, außer der Datei mit dem Code wirkt.
Gruß Hajo
AW: Noch eine Frage zum Makro
19.08.2012 17:25:14
Manu
Hallo Hajo,
das hab ich mir schon gedacht. Ich hoffe ich bin nicht unverschämt, aber kann man vor Beginn des Makro noch eine Messagebox öffnen, die darauf hinweist, das nur diese Datei (vor dem anlegen der anderen, dürfe es ja nur eine sein) geöffnet sein darf. Bei der Messagebox sollte man dann weiter oder abrechen klicken können. Bei weiter wird das Makro weiter ausgeführt, bei abrechen wird es abgebrochen.
Danke Dir.
LG Manu
Anzeige
AW: Noch eine Frage zum Makro
19.08.2012 17:30:43
Hajo_Zi
Hallo Manu,
man könnte es noch durch einen umfangreichen Code verhindern, das andere Dateien bearbeitet werden. Aber die MsgBox sollte reichen.
Option Explicit
Dim WbDatei As Workbook
Sub Teilen()
Dim LoI As Long
Dim LoJ As Long
Dim Bovorhanden As Boolean
Dim loletzte As Long
Dim WsTabelle As Worksheet
If MsgBox("Für dieses Makro darf nur diese Datei auf sein!!!" _
& Chr(13) & "Makro forsetzen?", vbYesNo + vbQuestion, "Makrofrage ?") = vbYes Then
Set WsTabelle = ActiveSheet
loletzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For LoI = 5 To loletzte
For LoJ = 18 To 23
If WsTabelle.Cells(LoI, LoJ)  "" Then
Bovorhanden = Vorhanden(WsTabelle.Cells(LoI, LoJ))
If Bovorhanden = False Then
Workbooks.Add
ActiveWorkbook.SaveAs Filename:= _
ThisWorkbook.Path & "\" & WsTabelle.Cells(LoI, LoJ) & ".xls", _
FileFormat:=xlNormal
WsTabelle.Rows(4).Copy ActiveWorkbook.Worksheets(1).Rows(1)
End If
With Workbooks(WsTabelle.Cells(LoI, LoJ) & ".xls").Worksheets(1)
WsTabelle.Rows(LoI).Copy .Rows(.UsedRange.SpecialCells( _
xlCellTypeLastCell).Row + 1)
End With
End If
Next LoJ
Next LoI
For Each WbDatei In Workbooks
If WbDatei.Name  ThisWorkbook.Name Then
WbDatei.Worksheets(1).Columns("Q:CE").Delete
WbDatei.Close True
End If
Next WbDatei
Set WsTabelle = Nothing
End If
End Sub
Function Vorhanden(StName As String) As Boolean
Vorhanden = False
For Each WbDatei In Workbooks
If Left(WbDatei.Name, InStrRev(WbDatei.Name, ".") - 1) = StName Then
Vorhanden = True
End If
Next WbDatei
End Function
Gruß Hajo
Anzeige
Danke
19.08.2012 17:39:53
Manu
Hallo Hajo,
danke, danke, danke. :-)
LG
Manu
AW: Makro mit Spezielfilter
18.08.2012 16:41:27
Hajo_Zi
Hallo Manu,
FileFormat _
:=xlNormal
Gruß Hajo
AW: Makro mit Spezielfilter
18.08.2012 15:46:59
Josef

Hallo Manu,
sollen die Ergebnisse wirklich in neue Dateien geschrieben werden oder in neue Tabellen?
In welcher Spalte kann das Ende der Liste ermittelt werden?

« Gruß Sepp »

Anzeige
AW: Makro mit Spezielfilter
18.08.2012 15:57:22
Manu
Hallo Sepp,
ja die Ergebnisse sollen in einer neuen Datei, am besten mit dem Dateinamen des Mitarbeiters gechrieben werden.
Zur Erklärung: Es handelt sich um eine Terminplanung für einen Monat. Pro Arbeitstag werden 22 Terminzeilen erfasst. Zu den einzelnen Terminen können jetzt in den Spalten R:W jeweils 5 Mitarbeiter eingeplant werden.
Wenn die Planung abgeschlossen ist, soll aus der großen Tabelle für jeden Mitarbeiter eine Datei abgespeichert werden, mit den Terminen, wo er im Einsatz ist.
Ich hoffe, daß ist verständlich :-)
Danke und Gruß
Manuela
AW: Makro mit Spezielfilter
18.08.2012 16:57:43
Josef

Hallo Manuela,
teste mal.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub manu()
  Dim objNewWB As Workbook
  Dim rng As Range, rngFind As Range, rngExport As Range
  Dim vntList As Variant, vntRange As Variant
  Dim lngIndex As Long, lngRow() As Long, lngFormat As Long
  Dim strfirst As String, strExt As String
  Dim lngCalc As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  With Sheets("Termine") 'Tabellennamen anpassen!
    Set rng = .Range("R1:W22") 'bereich evtl. anpassen!
    vntRange = rng
    vntList = toArraySorted(vntRange)
    For lngIndex = LBound(vntList) To UBound(vntList)
      Set rngExport = Nothing
      Set rngFind = Nothing
      Redim lngRow(0)
      Set rngFind = rng.Find(What:=vntList(lngIndex), LookIn:=xlValues, LookAt:=xlWhole, _
        MatchCase:=False, After:=rng.Cells(1, 1))
      
      If Not rngFind Is Nothing Then
        strfirst = rngFind.Address
        Do
          If IsError(Application.Match(rngFind.Row, lngRow, 0)) Then
            If rngExport Is Nothing Then
              Set rngExport = rngFind.EntireRow
            Else
              Set rngExport = Union(rngExport, rngFind.EntireRow)
            End If
            Redim Preserve lngRow(UBound(lngRow) + 1)
            lngRow(UBound(lngRow)) = rngFind.Row
          End If
          Set rngFind = rng.FindNext(rngFind)
        Loop While Not rngFind Is Nothing And strfirst <> rngFind.Address
      End If
      If Not rngExport Is Nothing Then
        Set objNewWB = Workbooks.Add(xlWBATWorksheet)
        rngExport.Copy objNewWB.Sheets(1).Range("A1")
        objNewWB.Sheets(1).Name = vntList(lngIndex)
        getFileExtAndFormat objNewWB, strExt, lngFormat
        objNewWB.SaveAs ThisWorkbook.Path & "\" & vntList(lngIndex) & strExt, lngFormat
        objNewWB.Close
      End If
    Next
  End With
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'manu'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Modul - Modul2"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
  End With
  
  Set objNewWB = Nothing
  Set rngExport = Nothing
  Set rngFind = Nothing
  Set rng = Nothing
End Sub


Private Function toArraySorted(Field As Variant, Optional Uniqe As Boolean = True) As Variant
  Dim objArrayList As Object
  Dim lngR As Long, lngC As Long
  
  On Error GoTo ErrExit
  
  Set objArrayList = CreateObject("System.Collections.Arraylist")
  
  With objArrayList
    For lngR = LBound(Field, 1) To UBound(Field, 1)
      For lngC = LBound(Field, 2) To UBound(Field, 2)
        If Not .Contains(Trim(Field(lngR, lngC))) Or Not Uniqe Then
          If Field(lngR, lngC) <> "" Then .Add Trim(Field(lngR, lngC))
        End If
      Next
    Next
    .Sort
    toArraySorted = .toArray
  End With
  
  Exit Function
  ErrExit:
  toArraySorted = -1
End Function


Private Function getFileExtAndFormat(ByRef WB As Workbook, ByRef strExt As String, ByRef lngFormat As Long)
  With WB
    If Val(Application.Version) < 12 Then
      strExt = ".xls": lngFormat = -4143
    Else
      Select Case WB.FileFormat
        Case 51: strExt = ".xlsx": lngFormat = 51
        Case 52:
          If .HasVBProject Then
            strExt = ".xlsm": lngFormat = 52
          Else
            strExt = ".xlsx": lngFormat = 51
          End If
        Case 56: strExt = ".xls": lngFormat = 56
        Case Else: strExt = ".xlsb": lngFormat = 50
      End Select
    End If
  End With
End Function



« Gruß Sepp »

Anzeige
AW: Makro mit Spezielfilter
18.08.2012 15:57:53
Manu
Hallo Sepp,
ja die Ergebnisse sollen in einer neuen Datei, am besten mit dem Dateinamen des Mitarbeiters gechrieben werden.
Zur Erklärung: Es handelt sich um eine Terminplanung für einen Monat. Pro Arbeitstag werden 22 Terminzeilen erfasst. Zu den einzelnen Terminen können jetzt in den Spalten R:W jeweils 5 Mitarbeiter eingeplant werden.
Wenn die Planung abgeschlossen ist, soll aus der großen Tabelle für jeden Mitarbeiter eine Datei abgespeichert werden, mit den Terminen, wo er im Einsatz ist.
Ich hoffe, daß ist verständlich :-)
Danke und Gruß
Manuela
AW: Makro mit Spezielfilter
18.08.2012 15:57:58
Manu
Hallo Sepp,
ja die Ergebnisse sollen in einer neuen Datei, am besten mit dem Dateinamen des Mitarbeiters gechrieben werden.
Zur Erklärung: Es handelt sich um eine Terminplanung für einen Monat. Pro Arbeitstag werden 22 Terminzeilen erfasst. Zu den einzelnen Terminen können jetzt in den Spalten R:W jeweils 5 Mitarbeiter eingeplant werden.
Wenn die Planung abgeschlossen ist, soll aus der großen Tabelle für jeden Mitarbeiter eine Datei abgespeichert werden, mit den Terminen, wo er im Einsatz ist.
Ich hoffe, daß ist verständlich :-)
Danke und Gruß
Manuela
AW: Makro mit Spezielfilter
18.08.2012 15:58:42
Manu
Hallo Sepp,
ja die Ergebnisse sollen in einer neuen Datei, am besten mit dem Dateinamen des Mitarbeiters gechrieben werden.
Zur Erklärung: Es handelt sich um eine Terminplanung für einen Monat. Pro Arbeitstag werden 22 Terminzeilen erfasst. Zu den einzelnen Terminen können jetzt in den Spalten R:W jeweils 5 Mitarbeiter eingeplant werden.
Wenn die Planung abgeschlossen ist, soll aus der großen Tabelle für jeden Mitarbeiter eine Datei abgespeichert werden, mit den Terminen, wo er im Einsatz ist.
Ich hoffe, daß ist verständlich :-)
Danke und Gruß
Manuela

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige