VBA - Filter zeigt Zellen basierend auf dem eingegebenen Passwort

Question

Ich (versuche) einen VBA-Code zu erstellen, der Sheet1 basierend auf dem eingegebenen Passwort filtert. Ich habe eine Excel-Datei mit 2 Blatt und Blatt2 hat die Passwörter in Spalte B und den "Filter" in Spalte A. Ich werde die Excel-Datei verteilen und geben Sie das entsprechende Passwort an die Parteien und wenn sie ihr Passwort alle Informationen von anderen eingeben Parteien werden gelöscht. Der Code:

Sub Open_with_password() 

pas = Application.InputBox("Input password") 
If pas = False Or pas = "" Then Exit Sub 
Application.ScreenUpdating = False 

a = 0 
For i = 1 To Sheet2.Range("A1").End(xlDown).Row 
    If Worksheets("Sheet2").Cells(i, 2) = pas Then 
     c = Worksheets("Sheet2").Cells(i, 1) 'the agency corresponding with the password 
     a = a + 1 
    End If 
Next 
'Check for password 
If a = 0 Then 
    MsgBox "Wrong password. Report can not be accessed" 
    ActiveWorkbook.Close False 

     Sheet2.Visible = xlSheetVeryHidden 
     Sheet1.Visible = xlSheetVeryHidden 

    Exit Sub 
    'If correct password 
Else: 
     Sheet1.Visible = xlSheetVisible 

     Worksheets("Sheet1").Select 
     Worksheets("Sheet1").Unprotect Password = "XYZ" 

     On Error Resume Next 
     ActiveSheet.ShowAllData 
     On Error GoTo 0 

    'Filter according to input password 
     If c <> "Admin" Then ActiveSheet.Range("$A$2:$AQ$500000").AutoFilter Field:=17, Criteria1:=c 
     Set rCell = ActiveSheet.AutoFilter.Range.Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells(1, 1) 
     Rows(rCell.Row).Select 
     Range(Selection, Selection.End(xlDown)).Copy 
     Worksheets("Sheet1").Select 
     Range("A2").Select 
     Selection.PasteSpecial Paste:=xlPasteValues, _ 
     Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
     Range("A2").Select 
    'If Admin 
     If c = "Admin" Then 
     Sheet2.Visible = xlSheetVisible 
     Sheet1.Visible = xlSheetVisible 
     End If 

End If 

Application.ScreenUpdating = True 

End Sub 

Die Fragen, die ich erlebt habe, so weit sind:
1. Wenn ich die Datei öffnen, wird das Eingabefeld nicht automatisch angezeigt, im Idealfall würde es zeigen, während der Benutzer nichts sieht.
2. Wenn es nach dem Passwort filtert (der Filter funktioniert), wenn es den Teil erreicht, wo es alles andere löschen soll, tut es das nicht. Ich bin eine Kopie und Paste-Methode und eine Fehlermeldung erscheint (Error 1004)

Dank für Ihre Hilfe

Answer 1

:

Wenn die Arbeitsmappe öffnet Ihr Makro aufrufen.

 
Private Sub Workbook_Open() 
    Open_with_password 
End Sub 

Ich würde Ihre Daten auf einem versteckten Arbeitsblatt intakt halten.

Sheet1.Visible = xlSheetVeryHidden

Kopieren Sie die gefilterten Zellen zu einem anderen Arbeitsblatt

 
Set rCell = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible) 
rcell.Copy Sheet2.Range("A1") 

Wenn die Arbeitsmappe klar Sheet2 schließt.

 
Private Sub Workbook_BeforeClose(Cancel As Boolean) 
    Sheet2.Cells.ClearContents 
End Sub 

Wenn Sie es auf diese Weise die Benutzer tun nicht in der Lage sein, die versteckten Daten zuzugreifen, wenn sie die Arbeitsmappe öffnen, ohne Makros zu aktivieren.

Answer 2

1.Code auf dem Workbook_Open() Ereignis sein sollte anerkannt verwenden, können Sie einen Anruf für einen anderen Unter -my Vorschlag machen -. In „Thisworkbook“ Objekt:

Private Sub Workbook_Open() 
Call Open_with_password 
End Sub 

2. Wenn Sie Copy-Paste verwenden, können Sie wählen in der Mitte nicht tun, so tun die Zwischenablage (normales Verhalten in Excel VBA) verloren, Sie daher wird nichts zu kleben haben, also der Fehler.

Rows(rCell.Row).Select 
     Range(Selection, Selection.End(xlDown)).Copy 
     Worksheets("Sheet1").Select 
     Range("A2").Select 'lost clipboard 
     Selection.PasteSpecial Paste:=xlPasteValues, _ 
     Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
     Range("A2").Select 

Änderung für

Rows(rCell.Row).Select 
     Range(Selection, Selection.End(xlDown)).Copy 
     Sheets("Sheet1").Range("A2").PasteSpecial Paste:=xlPasteValues 
     Excel.Application.CutCopyMode = False 'clears clipboard 

EDIT:

Es sollte funktionieren, egal, ob es Filter sind oder nicht.
OT: Nächster Schritt für Sie würde suchen, wie zu vermeiden wählen (das ist so viel Zeitaufwand). Vorschläge

Answer 3

ich meine eigene Frage zu beantworten bin, wie ich die folgende Lösung verwendet, und es scheint zu funktionieren:

Private Sub Workbook_Open() 
Call Open_with_password 
End Sub 

&

Sub Open_with_password() 
     Sheet2.Visible = xlSheetHidden 
     Sheet1.Visible = xlSheetHidden 
     Sheet3.Cells.ClearContents 
     Sheet1.Range("A1", "AQ1").Copy 
     Sheet3.Range("A1").PasteSpecial Paste:=xlPasteValues 

     Application.ScreenUpdating = False 
pas = Application.InputBox("Input password") 


If pas = False Or pas = "" Then Exit Sub 

a = 0 
For i = 1 To Sheet2.Range("A1").End(xlDown).Row 
    If Worksheets("Sheet2").Cells(i, 2) = pas Then 
     c = Worksheets("Sheet2").Cells(i, 1) 'the agency corresponding with the password 
     a = a + 1 
    End If 
Next 
'Check for password 
If a = 0 Then 
    MsgBox "Wrong password. Report can not be accessed" 
    ActiveWorkbook.Close False 

     Sheet2.Visible = xlSheetVeryHidden 
     Sheet1.Visible = xlSheetVeryHidden 

    Exit Sub 
    'If correct password 
Else: 
     Sheet1.Visible = xlSheetVisible 

     Worksheets("Sheet1").Select 
     Worksheets("Sheet1").Unprotect Password = "amazon" 

     On Error Resume Next 
     ActiveSheet.ShowAllData 
     On Error GoTo 0 

    'Filter according to input password 
     If c <> "Admin" Then ActiveSheet.Range("$A$2:$AQ$500000").AutoFilter Field:=17, Criteria1:=c 
     Set rCell = ActiveSheet.AutoFilter.Range.Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells(1, 1) 
     Rows(rCell.Row).Select 
     Range(Selection, Selection.End(xlDown)).Copy 
     Sheets("Sheet3").Range("A2").PasteSpecial Paste:=xlPasteValues 
     Excel.Application.CutCopyMode = False 'clears clipboard 
     Sheet1.Visible = xlSheetVeryHidden 
    'If Admin 
     If c = "Admin" Then 
     Sheet2.Visible = xlSheetVisible 
     Sheet1.Visible = xlSheetVisible 
     End If 

End If 

Application.ScreenUpdating = True 

End Sub