Über VBA kopieren des gefilterten Bereiches

Hallo an Alle

Könnte mir vielleicht jemand mit diesem Code weiterhelfen.

1. Problem: Er soll aus einer Mappe die Daten eines bestimmten Tabellenblattes Kopieren.
Jetzt habe ich das Problem das der Code in der Quell Tabelle den Filter in Zeile 3 aufhebt und ich weiß nicht wieso?

2. Problem: die Funktion zum Ermitteln ob die Datei schon offen ist, ist wohl nicht die richtige da der Code die Daten nicht Kopiert, wenn jemand anders im Netzwerk, die Datei offen hat. Eigentlich sollte diese Datei Schreibgeschützt geöffnet werden, unabhängig davon ob sie schon offen ist. Der Inhalt des Tabs Kopiert, und dann die Schreibgeschützte Datei wider geschlossen ohne zu speichern.

3. Problem: Ich hätte gern ein zweites Filterkriterium in derselben Spalte drinnen (die "1"), weiß aber nicht wie.

//'------------------------------------------------------------------------------ 
' Kopieren der Daten  
'------------------------------------------------------------------------------//  
    If IsFileOpen(Pfad) Then
        Set wksVerzeichnis = Workbooks("Aktuell.xlsm").Worksheets("Adressen")  
            With wksVerzeichnis.UsedRange
                .AutoFilter Field:=strFilter, Criteria1:=strKriterium
                .SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.ActiveSheet.Range("A1")  
                .AutoFilter
            End With
    Else
        Workbooks.Open filename:=Pfad, ReadOnly:=True
        Set wksVerzeichnis = Workbooks("Aktuell.xlsm").Worksheets("Adressen")  
    
            With wksVerzeichnis.UsedRange
                .AutoFilter Field:=strFilter, Criteria1:=strKriterium                                                       //'Zuweisen der Filter Nr und des Kriteriums//  
                .SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.ActiveSheet.Range("A1")    //'Kopieren der Daten//  
                .AutoFilter
                ActiveWindow.Close SaveChanges:=False
            End With
    End If

Das ist die Funktion:

Function IsFileOpen(filename As String)
    Dim filenum As Integer, errnum As Integer

    On Error Resume Next   //' Schaltet die Fehlerprüfung aus.//  
    filenum = FreeFile()   //' Erhalte eine freien Dateinummer.//  
//    ' Versuchen Sie, die Datei zu öffnen und sie zu sperren.//  
    Open filename For Input Lock Read As #filenum
    Close filenum         // ' Schließen Sie die Datei.//  
    errnum = Err           //' Speichern Sie die aufgetretene Fehlernummer.//  
    On Error GoTo 0        //' Schalten Sie die Fehlerprüfung erneut ein.//  

//    ' Überprüfen Sie, welcher Fehler aufgetreten ist.//  
    Select Case errnum

//        ' Es ist kein Fehler aufgetreten.  
        ' Datei ist NICHT bereits von einem anderen Benutzer geöffnet.//  
        Case 0
         IsFileOpen = False

 //       ' Fehlernummer für "Zugriff verweigert"  
        ' Die Datei wurde bereits von einem anderen Benutzer geöffnet.//  
        Case 70
            IsFileOpen = True

//        ' Ein weiterer Fehler ist aufgetreten.//  
        Case Else
            Error errnum
    End Select

End Function

Wäre echt nett wenn mir jemand bei einem oder sogar allen Drei Problemen weiterhelfen könnte.

Grüße
BlueLine

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 359577

Url: https://administrator.de/contentid/359577

Ausgedruckt am: 22.11.2024 um 19:11 Uhr

1 Kommentar

Das wäre noch der Ganze Code, falls das Hilft. Dazu gehört dann die Funktion von oben.

Private Sub CommandButton4_Click()
'Aktualisieren eines Tabellenblattes durch Kopieren  

    Dim Pfad As String                      'Pfad (Datenquelle)  
    Dim wksVerzeichnis As Worksheet    
    Dim strKriterium As String                 'Filter Kriterium  (für Datenquelle)  
    Dim strKriterium2 As String               'Filter Kriterium (für Datenquelle)  
    Dim strFilter As String                         ' Filter Nr (für Datenquelle)  
    Dim lngLetzteZeile As Integer           'Letzte Zeile  
        
'-----  
' Festlegen der Kriterien zum Filtern  
'-----  
   On Error GoTo Fehler2
    
    strFilter = "1"                                                     'Nummer des Filters in der Spalte des Filterkriteriums  
    strKriterium2 = "1"  
    strKriterium = ThisWorkbook.Worksheets("Tab1").Range("L1").Value 'Auslesen des Filterkriteriums aus Tab1  
    If strKriterium = "??" Then GoTo Fehler                             'Abbruch bei unzulässigem Filterkriterium  
    Pfad = "\\C:...................'Pfad zu Quelldatei  
    
'-----  
' Vorarbeiten  
'-----  
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    With ThisWorkbook.Worksheets("Adressen")  
        lngLetzteZeile = .UsedRange.Row + .UsedRange.Rows.Count + 1 'Letzte benutzte Zeile ermitteln  
               
        If lngLetzteZeile < 3 Then                                  'Prüfen ob letzte benutzte Zeile kleiner 4  
        
        Else
        .Cells.FormatConditions.Delete
        .Range(.Rows(3), .Rows(lngLetzteZeile)).EntireRow.Delete    'Alle Zeilen ab der 3. Zeile bis zur letzten benutzten Zeile löschen  
        End If
    
'-----  
' Kopieren der Daten  
'-----  
    If IsFileOpen(Pfad) Then
        Set wksVerzeichnis = Workbooks("Aktuell.xlsm").Worksheets("Adressen")  
            With wksVerzeichnis.UsedRange
                .AutoFilter Field:=strFilter, Criteria1:=strKriterium2, Criteria2:=strKriterium 'Zuweisen der Filter Nr und des Kriteriums  
                .SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.ActiveSheet.Range("A1")      'Kopieren der Daten  
                .AutoFilter
            End With
    Else
        Workbooks.Open filename:=Pfad, ReadOnly:=True
        Set wksVerzeichnis = Workbooks("Aktuell.xlsm").Worksheets("Adressen")  
    
            With wksVerzeichnis.UsedRange
                .AutoFilter Field:=strFilter, Criteria1:=strKriterium2, Criteria2:=strKriterium 'Zuweisen der Filter Nr und des Kriteriums  
                .SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.ActiveSheet.Range("A1")      'Kopieren der Daten  
                .AutoFilter
                ActiveWindow.Close SaveChanges:=False
            End With
    End If
    
'------  
' Abschluss und Fehlerbehandlung  
'------  
        Range("M1") = "Letzte Atualisierung " & vbCrLf & Now 'Datum un Uhrzeit der letzten Ausführung wird eingetragen.  
    End With
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Verzeichnis wurde Aktualisiert", vbInformation  
Exit Sub
    
Fehler:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Wählen sie auf Tabellenblatt Meldungen in Zelle L1 einen Bereich aus", vbInformation  
Exit Sub

Fehler2:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    If Err.Number <> 0 Then
    MsgBox Err.Description, vbCritical, Err.Number
    End If
End Sub