Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Blatt scannen und selektierten Inhalt auf neue Blätter
zurück: Kriterium den Inhalt (Text)aus Mappe1 A2 in Mappe2 suchen weiter: Laufzwitfehler 1004 bei Column(i,i).Delete Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Antwort Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
PhillipJudas
Neuling


Verfasst am:
12. Jul 2013, 08:02
Rufname:

Blatt scannen und selektierten Inhalt auf neue Blätter - Blatt scannen und selektierten Inhalt auf neue Blätter

Nach oben
       Version: Office 2010

Moin,

Ich beschäftige mich nun seit ca. einem Monat durch meinen Nebenjob sporadisch mit VBA.
Habe unten stehenden Code aus folgenden Vorgaben zusammengebastelt:

Aus einem Warenwirtschaftssystem wird jeden Tag ein Fehlerreport (CSV) abgerufen.
Diese enthält ca. 30000 (jedes Mal anders) Zeilen mit verschiedenen Fehlercodes.
Das Makro soll Fehlermeldungen von ausgewählten Fehlercodes (Spalte R) und davon nur ausgewählte Spalten jeweils in neue Tabellenblätter kopieren.
Der Name des neuen Tabellenblattes ist gleich dem Fehlercode.

Ich habe den Eindruck, dass meine Lösung nicht sehr schlank ist und im Moment bricht Excel bei der Ausführung häufig zusammen.

Ich bin auf eure Hilfe angewiesen, über Feedback würde ich mich sehr freuen .

Beste Grüße
Phillip

Code:

Option Explicit

Sub Worksheet_Change()

'-------------------------------------------------
' Variablendeklaration
'-------------------------------------------------
Dim rngZelle As Range
Dim lngLetzteZeile As Long
Dim lngLetzteZielZeile As Long
Dim lngZeile As Long
Dim strBlattname As String
Dim wksBlatt As Worksheet
Dim bolVorhanden As Boolean
Dim intCheck As Integer

'-------------------------------------------------
' Variableninitalisierung
'-------------------------------------------------
bolVorhanden = False

'-------------------------------------------------
' Bildschirmaktualisierung unterbinden
'-------------------------------------------------
Application.ScreenUpdating = False

'-------------------------------------------------
' Sonderzeichen in Fehlercodes (Spalte R) werden ersetzt
'-------------------------------------------------
Columns("R:R").Select
Selection.Replace What:="/", Replacement:="-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

lngLetzteZeile = Cells(Rows.Count, 1).End(xlUp).Row

'-------------------------------------------------
' Eine Nachrichtenbox wird eingerichtet
'-------------------------------------------------
UserForm1.Label1 = "Es werden " & lngLetzteZeile & " Datensätze durchlaufen und nach Fehlercodes geordnet und entsprechend der Fehlercodes sortiert sowie in neue Tabellenblätter kopiert. Bitte haben Sie etwas Geduld."
UserForm1.Show vbModeless
Application.Wait Now + TimeValue("00:00:01")

For Each rngZelle In Range("A2:A" & lngLetzteZeile)
  '-------------------------------------------------
  ' Zellinhalt in Spalte R = Meldung begrenzen,
  ' sonst Blattbenamung nicht möglich
  '-------------------------------------------------
  If Len(rngZelle.Offset(0, 17)) > 27 Then
  rngZelle.Offset(0, 17) = Left(rngZelle.Offset(0, 17), 25)
  End If
    strBlattname = rngZelle.Offset(0, 16) & " " & rngZelle.Offset(0, 17)
    intCheck = rngZelle.Offset(0, 16)
        '-------------------------------------------------
        ' prüfen ob das Blatt zur FehlerID schon existiert
        '-------------------------------------------------
        For Each wksBlatt In ActiveWorkbook.Sheets
            If wksBlatt.Name = strBlattname Then
              bolVorhanden = True
              Exit For
            Else
              bolVorhanden = False
            End If
        Next wksBlatt
      '-------------------------------------------------
      ' wenn nicht, Blatt erstellen
      '-------------------------------------------------
        If bolVorhanden = False Then
          ActiveWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)
          ActiveSheet.Name = strBlattname
        End If
       
         '-------------------------------------------------
         ' Spaltennamen und Daten eintragen
         '-------------------------------------------------
          ActiveWorkbook.Worksheets("NAME").Activate
          ActiveSheet.UsedRange.AutoFilter Field:=17, Criteria1:="=" & intCheck
          ActiveSheet.Range("D:D,E:E,F:F,H:H,J:J,K:K,L:L,M:M,N:N,O:O,P:P,Q:Q,R:R").Columns.Copy _
          Destination:=ActiveWorkbook.Worksheets("" & strBlattname).Range("A:M").Columns
     
Next rngZelle

ActiveWorkbook.Worksheets("NAME").Activate
ActiveSheet.AutoFilterMode = False
Unload UserForm1
MsgBox "Fertig!"
End Sub
l.key
Excel (VBA) brauchbar


Verfasst am:
12. Jul 2013, 15:08
Rufname:


AW: Blatt scannen und selektierten Inhalt auf neue Blätter - AW: Blatt scannen und selektierten Inhalt auf neue Blätter

Nach oben
       Version: Office 2010

Hallo Phillip,

ich denke, das Problem in deinem Code ist, dass du für alle Zellen den kompletten Filter- und Kopiervorgang durchläufst,
obwohl das bei Wiederholungen des Fehlercodes überflüssig ist. Das Kopieren selbst ist auch etwas zeitaufwändig.
Folgender Code sollte sehr viel schneller gehen, was auch dein Formular überflüssig macht.

Code:
Sub FehlerCodesFiltern()

'-------------------------------------------------
' Variablendeklaration
'-------------------------------------------------
Dim rngZelle As Range
Dim rngFehlerUnikate  As Range
Dim lngLetzteZeile As Long
Dim strBlattname As String
Dim shZiel As Worksheet
   
    On Error GoTo F
   
    '-------------------------------------------------
    ' Bildschirmaktualisierung, Berechnen, Ereignisse unterbinden
    '-------------------------------------------------
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
   
    '-------------------------------------------------
    ' Sonderzeichen in Fehlercodes (Spalte R) werden ersetzt
    '-------------------------------------------------
    With Sheets("NAME")
       
        If .AutoFilterMode Then .UsedRange.AutoFilter
       
        ' falls gewünscht vorher sortieren
        '.UsedRange.Sort Key1:=.Range("Q1"), Order1:=xlAscending, Header:=xlYes
       
        .Columns("R:R").Replace What:="/", Replacement:="-", LookAt:=xlPart
       
        lngLetzteZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
       
        .Range("R1:R" & lngLetzteZeile).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        On Error Resume Next
        Set rngFehlerUnikate = .Range("Q2:Q" & lngLetzteZeile).SpecialCells(xlCellTypeVisible)
        On Error GoTo F
        .ShowAllData
       
        If Not rngFehlerUnikate Is Nothing Then
            For Each rngZelle In rngFehlerUnikate
           
                strBlattname = Trim(rngZelle & " " & rngZelle.Offset(0, 1))
               
                '-------------------------------------------------
                ' prüfen ob das Blatt zur FehlerID schon existiert
                ' wenn nicht, Blatt erstellen
                '-------------------------------------------------
                If ErlaubterBlattName(strBlattname) Then
                    If BlattExistiert(strBlattname) Then
                        Set shZiel = Sheets(strBlattname)
                        shZiel.UsedRange.Clear
                    Else
                        Set shZiel = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                        shZiel.Name = strBlattname
                    End If
                   
                    '-------------------------------------------------
                    ' Spaltennamen und Daten eintragen
                    '-------------------------------------------------
                    .UsedRange.AutoFilter Field:=17, Criteria1:="=" & rngZelle
                    Application.Intersect(.Range("D:F,H:H,J:R"), .AutoFilter.Range).Copy Destination:=shZiel.Cells(1)
                    shZiel.UsedRange.EntireColumn.AutoFit
                End If
            Next rngZelle
            .Activate
            .AutoFilterMode = False
        End If
    End With

F:  Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    If Err = 0 Then
        MsgBox "Fertig!"
    Else
        MsgBox Err.Description, , "Fehler Nr. " & Err.Number
    End If
End Sub

Private Function BlattExistiert(strName As String) As Boolean
    On Error Resume Next
    BlattExistiert = Not Sheets(strName) Is Nothing
    On Error GoTo 0
End Function

Private Function ErlaubterBlattName(strName As String) As Boolean
Dim varPos As Variant
    For Each varPos In Array(":", "\", "/", "[", "]", "*", "?")
        strName = Replace(strName, varPos, "")
    Next
    strName = Left(strName, 31)
    If strName <> "" Then ErlaubterBlattName = True
End Function

_________________
Grüße, Klaus.
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Excel Formeln: Filter über mehrere Blätter gleichzeitig 0 Holger 996 836 04. Mai 2006, 12:04
Holger 996 Filter über mehrere Blätter gleichzeitig
Keine neuen Beiträge Excel Formeln: Dateipfad auf jedem Blatt anzeigen 7 Rudissimo 7505 30. März 2006, 13:39
Rudissimo Dateipfad auf jedem Blatt anzeigen
Keine neuen Beiträge Excel Formeln: 2 Blätter Inhalt vergleichen und in neues Blatt schreib. usw 1 meiej 1148 24. März 2006, 18:31
Klaus-Dieter 2 Blätter Inhalt vergleichen und in neues Blatt schreib. usw
Keine neuen Beiträge Excel Formeln: Kontobewegungen - wie neue Posten automat. berücksichtigen? 2 orstenpowers 691 02. März 2006, 08:00
< Peter > Kontobewegungen - wie neue Posten automat. berücksichtigen?
Keine neuen Beiträge Excel Formeln: Format Inhalt auslesen 7 shanghai357 5567 10. Feb 2006, 17:24
shanghai357 Format Inhalt auslesen
Keine neuen Beiträge Excel Formeln: Zählen von Zellen mit Inhalt mit Ausnahmen 2 Florian 1929 10. Feb 2006, 10:30
Florian Zählen von Zellen mit Inhalt mit Ausnahmen
Keine neuen Beiträge Excel Formeln: Zeilen mit gleichem Inhalt löschen 1 Gast 4171 06. Jan 2006, 15:03
ae Zeilen mit gleichem Inhalt löschen
Keine neuen Beiträge Excel Formeln: !!! ZÄHLENWENN 2 Felder den gleichen Inhalt haben ???? 2 Brummy 1815 23. Nov 2005, 22:29
Brummy !!!  ZÄHLENWENN 2 Felder den gleichen Inhalt haben ????
Keine neuen Beiträge Excel Formeln: E2K3 : Addition mehrerer Zellen über verschiedene Blätter 2 Gast 1107 08. Nov 2005, 17:14
cw E2K3 : Addition mehrerer Zellen über verschiedene Blätter
Keine neuen Beiträge Excel Formeln: Bestimmte Inhalte einer Spalte in eine neue Spalte 8 Johanna59 1104 30. Okt 2005, 20:51
Maxel3113 Bestimmte Inhalte einer Spalte in eine neue Spalte
Keine neuen Beiträge Excel Formeln: Blatt kopieren 6 Noby 748 15. Aug 2005, 13:44
noby Blatt kopieren
Keine neuen Beiträge Excel Formeln: Suchen und übereinstimmung in neue Zeile 2 Sternenhimmel75 821 03. Aug 2005, 08:27
Sternenhimmel75 Suchen und übereinstimmung in neue Zeile
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: Web Editor Forum