EnableAutoFilter Funktioniert nicht
19.05.2020 13:35:34
Manuel
Ich habe ein Macro geschrieben, siehe unten, das zwei Excel Datein abgleicht. Die Veränderungen farblich markiert und dann am ende eine Spalte hinzufügt, etwas ausblendet, einen Filter einfügt und am Ende ein Schreibschutz setzt.
Alles funktioniert soweit und auch zuverlässig nur die Filter nicht.
ich nutze
.Protect userinterfaceonly:=True
.EnableOutlining = True
.EnableAutoFilter = True
dafür.
Ich habe schon alles neugestartet,und sonstige Tipps befolgt die man so finden kann und bin jetzt langsam am ende angekommen was ich noch Probieren könnte...
Vielleicht hat ja jemand eine Idee.
Viele Grüße
Manuel
Sub Makro2()
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objDateienliste As Object
Dim objDatei As Object
Dim objFileSystemAlt As Object
Dim objVerzeichnisAlt As Object
Dim objDateienlisteAlt As Object
Dim objDateiAlt As Object
Dim strDir As String
Dim strAktDir As String
Dim colDir As New Collection
Dim x As Integer, colZealer As Integer, z As Integer, rowAlt As Integer, SNCol As Integer, id _
As Integer, maxcol As Integer
Dim checkValue As String
Dim myRange As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
PfadNeu = ActiveWorkbook.Path
Set objFileSystem = CreateObject("scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.GetFolder(PfadNeu)
Set objDateienliste = objVerzeichnis.Files
For i = Len(PfadNeu) To 1 Step -1
If Mid(PfadNeu, i, 1) = "\" Then
Ordnerpfad = Left(PfadNeu, i)
Ordnername = Right(PfadNeu, Len(PfadNeu) - i)
Exit For
End If
Next i
colDir.Add Ordnerpfad
Do While colDir.Count > 0
strAktDir = colDir.Item(1)
colDir.Remove 1
strDir = Dir$(strAktDir, vbDirectory)
OrdnerAlt = "Leer"
Do While Len(strDir) > 0
If (strDir ".") And (strDir "..") And (strDir Ordnername) Then
If strDir "Leer" Then
Set objFileSystemAlt = CreateObject("scripting.FileSystemObject")
Set objVerzeichnisAlt = objFileSystemAlt.GetFolder(Ordnerpfad & "\" & OrdnerAlt)
For Each objDatei In objDateienliste
If Not objDatei Is Nothing And objDatei.Name "DM_Listing_Macro.xlsm" And InStr( _
objDatei.Name, "Randomized_Subjects") = 0 Then
Set objDateienlisteAlt = objVerzeichnisAlt.Files
checkname = Left(objDatei.Name, Len(objDatei.Name) - 20)
For Each objDateiAlt In objDateienlisteAlt
If Not objDateiAlt Is Nothing And objDateiAlt.Name "DM_Listing_Macro.xlsm" _
And InStr(objDateiAlt.Name, "Randomized_Subjects") = 0 Then
checknameAlt = Left(objDateiAlt.Name, Len(objDateiAlt.Name) - 20)
If checknameAlt = checkname Then
Workbooks.Open objDatei
Workbooks.Open objDateiAlt
Workbooks(objDatei.Name).Sheets(1).Unprotect
Workbooks(objDateiAlt.Name).Sheets(1).Unprotect
x = 1
Do While Workbooks(objDatei.Name).Sheets(1).Cells(x, 2).Value " _
mnpdid" And Workbooks(objDatei.Name).Sheets(1).Cells(x, 3).Value "mnpdid"
x = x + 1
If Workbooks(objDatei.Name).Sheets(1).Cells(x, 3).Value = " _
mnpdid" Then
SNCol = 2
id = 3
ElseIf Workbooks(objDatei.Name).Sheets(1).Cells(x, 2).Value = " _
mnpdid" Then
SNCol = 1
id = 2
End If
Loop
colZealer = 2
Do While Workbooks(objDateiAlt.Name).Sheets(1).Cells(x, colZealer). _
Value ""
colZealer = colZealer + 1
Loop
maxcol = colZealer
z = 0
Do While Workbooks(objDatei.Name).Sheets(1).Cells(z + x + 2, SNCol). _
Value ""
checkValue = Workbooks(objDatei.Name).Sheets(1).Cells(z + x + 2, _
id).Value
rowAlt = 0
Do While Workbooks(objDatei.Name).Sheets(1).Cells(rowAlt + x + _
2, SNCol).Value ""
If Workbooks(objDateiAlt.Name).Sheets(1).Cells(rowAlt + x + _
2, id).Value = checkValue Then
colZealer = 2
Do While Workbooks(objDateiAlt.Name).Sheets(1).Cells(x, _
colZealer).Value ""
If Workbooks(objDatei.Name).Sheets(1).Cells(z + x + _
2, colZealer).Value Workbooks(objDateiAlt.Name).Sheets(1).Cells(rowAlt + x + 2, colZealer).Value Then
Workbooks(objDatei.Name).Sheets(1).Cells(z + x + _
2, colZealer).Interior.Color = RGB(255, 193, 37)
End If
colZealer = colZealer + 1
Loop
ElseIf Workbooks(objDateiAlt.Name).Sheets(1).Cells(rowAlt + _
x + 2, SNCol).Value = "" Then
Workbooks(objDatei.Name).Sheets(1).Activate
Workbooks(objDatei.Name).Sheets(1).Range(Cells(rowAlt + _
x + 2, 1), Cells(rowAlt + x + 2, maxcol)).Interior.Color = RGB(78, 238, 148)
End If
rowAlt = rowAlt + 1
Loop
z = z + 1
Loop
Set myRange = Workbooks(objDatei.Name).Sheets(1).Range(Workbooks( _
objDatei.Name).Sheets(1).Cells(x, SNCol), Workbooks(objDatei.Name).Sheets(1).Cells(x, maxcol))
If Not Workbooks(objDatei.Name).Sheets(1).AutoFilterMode Then
With myRange
.Locked = False
.AutoFilter
End With
End If
With Workbooks(objDatei.Name).Sheets(1)
.Columns(id).Hidden = True
.Columns(maxcol + 1).Insert
.Cells(x, maxcol).Value = "Comment"
.Columns(maxcol).Locked = False
.Protect userinterfaceonly:=True
.EnableOutlining = True
.EnableAutoFilter = True
End With
Workbooks(objDatei.Name).Close saveChanges:=True
Workbooks(objDateiAlt.Name).Close saveChanges:=True
Exit For
End If
End If
Next objDateiAlt
End If
Next objDatei
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub