MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Excel
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 15.03.2019, 13:43   #1
Quartzlurch
MOF User
MOF User
Standard Frage - Kopiervorgang dauert sehr lange, zu lange!

MS Office 365
Prozessor: Intel(R) Core(TM) i7-7500U CPU @ 2.70GHz 2.90 GHz
RAM: 16,0 GB
Systemtyp: 64-Bit-Betriebssystem, x64-basierter Prozessor

Hallo Excelfreunde,

ich hätte euch gerne die Datei hochgeladen, diese ist aber, trotzdem, dass ich alles unnötige weggelassen habe viel zu groß.

Ich erkläre mal kurz um was es geht:

Von dem Bereich der Tabelle("Vokabeln") = A2:E5000, sollen per Makro alle Felder in Spalte "E" auf richtig oder Fehler überprüft werden. Alle Zeilen die "Fehler" enthalten sollen kopiert werden bis zum letzten Eintrag in Spalte A und in das Tabellenblatt("Falsche Vokabeln1") eingefügt werden. Es sollen keine doppelten Datensätze eingefügt werden.

Das Makro das ich mir zusammengestellt habe funktioniert zwar, habe aber festgestellt, dass bei der Annahme alle 5000 Datensätze seien falsch, das Makro 6 Minuten braucht um alle Datensätze zu übertragen. Dass das Makro nicht optimal erstellt ist habe ich mir schon gedacht, aber 6 Minuten sind extrem lange!

Da sollte doch bestimmt der Makroablauf optimiert werden können. Ohne eure Hilfe krieg ich das nicht hin. Wäre "Super", wenn ich den einen oder anderen Tip von euch bekäme. Über's Wochenende bin ich außer Haus, komme am späten Sonntag Abend wieder nach Hause.

Ich bedanke mich schon jetzt für jedwede Hilfe von Euch.

Hier der Code:

Option Explicit

Sub Zeilen_in_Falsche_Vokabeln1_kopieren()
' Die Zeilen falsch beantworteter Vokabeln werden
' in das Tabellenblatt "Falsche Vokabeln1" kopiert
'
'
'

Application.ScreenUpdating = False 'Schaltet den Bildschirm aus

Dim i As Long
Dim tLR As Long
Dim tarWks As Worksheet
Dim srcWks As Worksheet

Set srcWks = Worksheets("Vokabeln")
Set tarWks = Worksheets("Falsche Vokabeln1")

i = MsgBox("Sollen die Daten wirklich übertragen werden?" _
& vbCr & "Gute Entscheidung nochmal zu wiederholen!!!", vbYesNo + vbQuestion, "Frage vom Lehrer!")

Sheets("Vokabeln").Select

If i = vbYes Then

Sheets("Vokabeln").Range("J18").Select
If Range("J18") = "x" Then

With srcWks
For i = 1 To .Cells(.Rows.Count, 5).End(xlUp).Row
If .Cells(i, 5).Value = "Fehler" Then
tLR = tarWks.Cells(Rows.Count, "A").End(xlUp).Row + 1
Debug.Print tLR

With tarWks
.Range(.Cells(tLR, 1), .Cells(tLR, 5)).Value = srcWks.Range(srcWks.Cells(i, 1), _
srcWks.Cells(i, 5)).Formula

End With

'Alle alten Formeln im Sheets("Falsche Vokabeln1"), in Spalte E löschen und neue Formeln einfügen.
With tarWks

'Alle Formeln (richtig/Fehler) löschen
.Range("E2:E" & .Cells(Rows.Count, "E").End(xlUp).Row).ClearContents

'Nur die falschen Antworten in Spalte "D" löschen
.Range("$D$2:$D" & .Cells(Rows.Count, "D").End(xlUp).Row).ClearContents

'Alle neuen Formeln (richtig/Fehler) einfügen
.Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
"=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"

Range("D2").Select


End With

End If

Next i

End With


Else


With srcWks
For i = 1 To .Cells(.Rows.Count, 5).End(xlUp).Row
If .Cells(i, 5).Value = "Fehler" Then
tLR = tarWks.Cells(Rows.Count, "A").End(xlUp).Row + 1
Debug.Print tLR

With tarWks
.Range(.Cells(tLR, 1), .Cells(tLR, 5)).Value = srcWks.Range(srcWks.Cells(i, 1), _
srcWks.Cells(i, 5)).Formula

End With

'Alle alten Formeln im Sheets("Falsche Vokabeln1"), in Spalte E löschen und neue Formeln einfügen.
With tarWks

'Nur die falschen Antworten in Spalte "D" löschen
.Range("$D$2:$D" & .Cells(Rows.Count, "D").End(xlUp).Row).ClearContents

'Alle Formeln (richtig/Fehler) löschen
.Range("E2:E" & .Cells(Rows.Count, "E").End(xlUp).Row).ClearContents

'Alle doppelten Vokabeln löschen
.Range("$A$1:$E" & .Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates _
Columns:=1, Header:=xlYes

'Alle neuen Formeln (richtig/Fehler) einfügen
.Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
"=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"

Range("D2").Select

End With

End If

Next i

End With

End If

Else

MsgBox "OK, die Daten werden nicht übertragen!"

End If

Sheets("Falsche Vokabeln1").Activate
Range("D2").Select


Set srcWks = Nothing
Set tarWks = Nothing

Application.ScreenUpdating = True 'Schaltet den Bildschirm ein

End Sub
Quartzlurch ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 13:54   #2
MisterBurns
MOF Meister
MOF Meister
Standard

Also ich bin ja der Meinung, dass du mit beinahe 200 Beiträgen im Forum selbst hättest wissen können, dass wohl ohne Beispielmappe keiner deinen Code durchackern wird auf den Verdacht hin, etwas verbessern zu können...

Auch solltest du das System der Codetags mittlerweile verstanden haben, welche das Codelesen ungemein erleichtern. Das gleiche gilt für Einrückungen im Code.

Ohne nun also deinen Code gelesen zu haben, stelle ich mal die generelle Frage, wieso filterst du nicht nach Spalte E und kopierst dann sämtliche Fehlereinträge auf einmal? Das ist die schnellte Art lange Listen zu überprüfen. Schleifen sind nun mal Schnecken. Allerdings finde ich 6 Minuten bei 5000 Zeilen dennoch fragwürdig.

__________________

Schöne Grüße
Berni
MisterBurns ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 15:06   #3
feliweb
MOF User
MOF User
Standard

Hi,
ich kann mich da MisterBurns nur anschließen.
Aber füge das mal noch an den Anfang bzw ans Ende


Application.Calculation = xlCalculationManual 'automat.Berechnung ausschalten

'***Deine Anweisungen***

Application.Calculation = xlCalculationAutomatic 'automat.Berechnung einschalten
feliweb ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 16:42   #4
Der Steuerfuzzi
MOF Profi
MOF Profi
Standard

Hallo,

hier ein paar Anmerkungen:
1) Du solltest Code-Tags verwenden. Deine Buchstabensuppe ist nicht leserlich!
2) Du hast in beiden Schleifen Debug.Print-Anweisung. Nimm diese heraus, wenn Du es nicht mehr brauchst (die machen den Ablauf langsam).
3) Du hast in beiden Schleifen ein Range("D2").Select. Nimm auch das raus, das brauchst Du nicht!
4) Du beackerst einen Bereich und liest zellenweise Werte aus. Das ist langsam. Man könnte darüber nachdenken, das ganze in einer Array-Variablen zwischenzuspeichern
5a) Du löscht Bereiche und fügst Formeln in einer Schleife sehr häufig ein. Ich vermute, dass diese Aktion redundant ist (das sollte einmal nach der Schleife reichen).
5b) Warum kopierst Du eigentlich die Spalten A bis E, wenn Du D und E danach sowieso löscht. Kopier doch einfach nur A-C, dann kannst Du Dir das löschen auch sparen.
6) Ohne Beispieldatei kann man nix genaueres nicht sagen! -> Vermutlich ist es ein Folgethread von diesem (mit Beispieldatei): https://www.ms-office-forum.net/foru...40#post1917040

EDIT: Wenn man .Value2 statt .Value verwendet, kann das auch einen (kleinen) Geschwindigkeitsgewinn bringen (allerdings wird das bei Dir nicht die Lösung sein!)

__________________

Gruß
Michael

Geändert von Der Steuerfuzzi (15.03.2019 um 17:03 Uhr).
Der Steuerfuzzi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 16:50   #5
Storax
MOF Koryphäe
MOF Koryphäe
Standard

Ohne Datei reicht vielleicht das aus (Tipps 1-3 von Der Steuerfuzzi umgesetzt + Abschalten Events)
Code:

Option Explicit

Sub Zeilen_in_Falsche_Vokabeln1_kopieren()
' Die Zeilen falsch beantworteter Vokabeln werden
' in das Tabellenblatt "Falsche Vokabeln1" kopiert
'
'
'

Dim i As Long
Dim tLR As Long
Dim tarWks As Worksheet
Dim srcWks As Worksheet

    Application.Calculation = xlCalculationManual
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set srcWks = Worksheets("Vokabeln")
    Set tarWks = Worksheets("Falsche Vokabeln1")

    i = MsgBox("Sollen die Daten wirklich übertragen werden?" _
               & vbCr & "Gute Entscheidung nochmal zu wiederholen!!!", vbYesNo + vbQuestion, "Frage vom Lehrer!")

    Sheets("Vokabeln").Select

    If i = vbYes Then

        Sheets("Vokabeln").Range("J18").Select
        If Range("J18") = "x" Then

            With srcWks
                For i = 1 To .Cells(.Rows.Count, 5).End(xlUp).Row
                    If .Cells(i, 5).Value = "Fehler" Then
                        tLR = tarWks.Cells(Rows.Count, "A").End(xlUp).Row + 1
                        ' Debug.Print tLR

                        With tarWks
                            .Range(.Cells(tLR, 1), .Cells(tLR, 5)).Value = srcWks.Range(srcWks.Cells(i, 1), _
                                                                                        srcWks.Cells(i, 5)).Formula

                        End With

                        'Alle alten Formeln im Sheets("Falsche Vokabeln1"), in Spalte E löschen und neue Formeln einfügen.
                        With tarWks

                            'Alle Formeln (richtig/Fehler) löschen
                            .Range("E2:E" & .Cells(Rows.Count, "E").End(xlUp).Row).ClearContents

                            'Nur die falschen Antworten in Spalte "D" löschen
                            .Range("$D$2:$D" & .Cells(Rows.Count, "D").End(xlUp).Row).ClearContents

                            'Alle neuen Formeln (richtig/Fehler) einfügen
                            .Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
                            "=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"

                            'Range("D2").Select


                        End With

                    End If

                Next i

            End With


        Else


            With srcWks
                For i = 1 To .Cells(.Rows.Count, 5).End(xlUp).Row
                    If .Cells(i, 5).Value = "Fehler" Then
                        tLR = tarWks.Cells(Rows.Count, "A").End(xlUp).Row + 1
                        'Debug.Print tLR

                        With tarWks
                            .Range(.Cells(tLR, 1), .Cells(tLR, 5)).Value = srcWks.Range(srcWks.Cells(i, 1), _
                                                                                        srcWks.Cells(i, 5)).Formula

                        End With

                        'Alle alten Formeln im Sheets("Falsche Vokabeln1"), in Spalte E löschen und neue Formeln einfügen.
                        With tarWks

                            'Nur die falschen Antworten in Spalte "D" löschen
                            .Range("$D$2:$D" & .Cells(Rows.Count, "D").End(xlUp).Row).ClearContents

                            'Alle Formeln (richtig/Fehler) löschen
                            .Range("E2:E" & .Cells(Rows.Count, "E").End(xlUp).Row).ClearContents

                            'Alle doppelten Vokabeln löschen
                            .Range("$A$1:$E" & .Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates _
                                    Columns:=1, Header:=xlYes

                            'Alle neuen Formeln (richtig/Fehler) einfügen
                            .Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
                            "=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"

                            ' Range("D2").Select

                        End With

                    End If

                Next i

            End With

        End If

    Else

        MsgBox "OK, die Daten werden nicht übertragen!"

    End If

    Sheets("Falsche Vokabeln1").Activate
    Range("D2").Select


    Set srcWks = Nothing
    Set tarWks = Nothing

    Application.Calculation = xlCalculationAutomatic
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

__________________

How do I ask a good question?

In a lot questions the OP has no idea what they're doing, they've found code on the internet, mixed it around and got something. They don't understand why that something doesn't work.
Usually, in these questions, the original poster is rather clueless, helping them on the question is only spoon feeding them, and there is little to no chance the question will help anyone in the future.

Press any key to continue - or any other key to abort.

Spoon feeding: provide (someone) with so much help or information that they do not need to think for themselves.
Storax ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 18:05   #6
Quartzlurch
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hallo an Alle,

danke für eure Aufmerksamkeit. Habe eine wirklich abgespeckte Version in einem Arbeitsblatt für euch im Anhang. Da ist kein Autofilter mehr drin und die vier Module mit diversen anderen Macros fehlen auch. Kann ja leider nur 97 kB uploaden. Die Spalten ("A : D") müsstet ihr dann eben bis 5000 runterziehen. Die Spalte "B"= Lösung, ist normalerweise ausgeblendet.

Warum ich das wie gemacht habe? ich kann's leider nicht besser. Wegen dem Code zu präsentieren, habe Probleme mit Excel-Jeannie. hatte das vor vielen Jahren unter Excel 2003 eingesetzt aber mit der Version von Office 365 Home gelingt mir das nicht, da gab's eine Fehlermeldung die ich leider vergaß.

Gruß Horst
Angehängte Dateien
Dateityp: xlsm Kopieren ohne Doppelte_Beispielmappe.xlsm (97,6 KB, 5x aufgerufen)
Quartzlurch ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 18:11   #7
Quartzlurch
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hallo Storax,

Danke für deine Hilfe. Habe den von dir geänderten Code probiert, da gab's den Laufzeitfehler 1004 in folgendem Bereich:

With tarWks
.Range(.Cells(tLR, 1), .Cells(tLR, 5)).Value = srcWks.Range(srcWks.Cells(i, 1), _
srcWks.Cells(i, 5)).Formula

Gruß Horst
Quartzlurch ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 18:58   #8
Storax
MOF Koryphäe
MOF Koryphäe
Standard

Den Teil habe ich nicht geändert und wenn Du das nicht wechseln kannst, ooh ooh.

Nimm die Zeilentrennung raus, das dürfte beim Kopieren schief gegangen sein.

__________________

How do I ask a good question?

In a lot questions the OP has no idea what they're doing, they've found code on the internet, mixed it around and got something. They don't understand why that something doesn't work.
Usually, in these questions, the original poster is rather clueless, helping them on the question is only spoon feeding them, and there is little to no chance the question will help anyone in the future.

Press any key to continue - or any other key to abort.

Spoon feeding: provide (someone) with so much help or information that they do not need to think for themselves.
Storax ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 18.03.2019, 09:16   #9
Der Steuerfuzzi
MOF Profi
MOF Profi
Standard

Ich habe mal versucht, den Code umzubauen. Bin mir zwar nicht sicher, ob er das macht, was Du willst, aber probier es mal aus:
Code:

Sub Zeilen_in_Falsche_Vokabeln1_kopieren()
    ' Die Zeilen falsch beantworteter Vokabeln werden
    ' in das Tabellenblatt "Falsche Vokabeln1" kopiert

    Dim i       As Long
    Dim tarWks  As Worksheet
    Dim srcWks  As Worksheet
        
    i = MsgBox("Sollen die Daten wirklich übertragen werden?" _
        & vbCr & "Gute Entscheidung nochmal zu wiederholen!!!", vbYesNo + vbQuestion, "Frage vom Lehrer!")
    
    If i = vbYes Then
        Application.ScreenUpdating = False   'Schaltet den Bildschirm aus
        Set srcWks = Worksheets("Vokabeln")
        Set tarWks = Worksheets("Falsche Vokabeln1")
        ' Schreibschutz_aufheben Makro
        ' Schreibschutz aufheben "Vokabeln" und Spalten einfügen!
        Schutz_aus srcWks
        Schutz_aus tarWks
        With srcWks
             'Autofilter: nur "Fehler" sichtbar
             If Not .AutoFilterMode Then Range("A1").AutoFilter
             Range("A1").AutoFilter Field:=5, Criteria1:="Fehler"
             'Sichtbare Zellen kopieren
             .Range(.Cells(2, 1), .Cells(.Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy tarWks.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
             If Sheets("Vokabeln").AutoFilterMode Then Range("A1").AutoFilter
             'Fomel eintragen
             With tarWks
                 .Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
                         "=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"
             End With
        End With
        If srcWks.Range("J18") <> "x" Then
             With tarWks
                'Alle doppelten Vokabeln löschen
                .Range("$A$1:$E" & .Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates _
                 Columns:=1, Header:=xlYes
             End With
         End If
        Schutz_an srcWks
        Schutz_an tarWks
        tarWks.Activate
        Set srcWks = Nothing
        Set tarWks = Nothing
        Application.ScreenUpdating = True   'Schaltet den Bildschirm ein
    Else
        MsgBox "OK, die Daten werden nicht übertragen!"
    End If
End Sub
Sub Schutz_aus(wks As Worksheet)
    wks.Unprotect Password:=""
    wks.Columns("A:H").Hidden = False
End Sub
Sub Schutz_an(wks As Worksheet)
    wks.Range("B:B, G:G").EntireColumn.Hidden = True
    wks.Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

__________________

Gruß
Michael
Der Steuerfuzzi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 18.03.2019, 15:34   #10
Quartzlurch
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hallo Michael,

vielen Dank für dein Engagement und sorry, dass ich mich erst jetzt zurück melde. Zu dem veränderten Code, das sind "zwei Unterschiede wie Tag und Nacht"! Die Schnelligkeit der Übertragung ist vllt. gerade mal 1 Sekunde. Wahnsinn. Ich habe noch ein wenig Probleme den Code dem Autofilter anzupassen in meinem eigentlichen Arbeitsblatt. Ich versuche es alleine hinzukriegen, wenn nicht melde ich mich nochmal. Nochmals: "recht herzlichen Dank an dich!"

P.S:
Wäre schön, wenn Du mir noch ein wenig Infos zum "besseren Verstehen" zukommen lassen könntest über folgende Teile:

If Not .AutoFilterMode Then Range("A1").AutoFilter
Range("A1").AutoFilter Field:=5, Criteria1:="Fehler"

.Range(.Cells(2, 1), .Cells(.Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy tarWks.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
If Sheets("Vokabeln").AutoFilterMode Then Range("A1").AutoFilter

Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
"=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"
Quartzlurch ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 19.03.2019, 08:15   #11
Der Steuerfuzzi
MOF Profi
MOF Profi
Standard

Im Grunde habe ich Deinen Code verwendet. Bei Dir war zweimal fast der identische Code enthalten, den habe ich reduziert. Zudem habe ich bestimmte Teile an sinnvollere Stellen umgestellt (z. B. Screenupdating und den Schutz aufheben brauche ich nur, wenn ich tatsächlich etwas am Blatt ändere). Außerdem habe ich die Schleife entfernt, die nicht notwendig ist. Die Schleife wurde nur dazu benutzt, die Daten zu Filtern, das macht jetzt der Autofilter. In der Schleife wurden außerdem in jedem Durchgang Daten kopiert und Formeln eingefügt, das macht das Makro langsam. Ich kopiere die gefilterten Daten einmal in das andere Arbeitsblatt. DAs geht schneller.

Ich habe allerdings noch einen Fehler in meinem Code gefunden (es hat ein Punkt gefehlt) und zusätzlich noch ein paar Anmerkungen ergänzt (ich hoffe das hilft):
Code:

Sub Zeilen_in_Falsche_Vokabeln1_kopieren()
    ' Die Zeilen falsch beantworteter Vokabeln werden
    ' in das Tabellenblatt "Falsche Vokabeln1" kopiert

    Dim i       As Long
    Dim tarWks  As Worksheet
    Dim srcWks  As Worksheet
        
    i = MsgBox("Sollen die Daten wirklich übertragen werden?" _
        & vbCr & "Gute Entscheidung nochmal zu wiederholen!!!", vbYesNo + vbQuestion, "Frage vom Lehrer!")
    
    If i = vbYes Then
        Application.ScreenUpdating = False   'Schaltet den Bildschirm aus
        Set srcWks = Worksheets("Vokabeln")
        Set tarWks = Worksheets("Falsche Vokabeln1")
        ' Schreibschutz_aufheben ausgelagert in eine eigene Sub:
        Schutz_aus srcWks
        Schutz_aus tarWks
        With srcWks
             'Autofilter: nur "Fehler" sichtbar
             If Not .AutoFilterMode Then Range("A1").AutoFilter 'Wenn im Blatt kein Autofilter, dann Filter setzen
             .Range("A1").AutoFilter Field:=5, Criteria1:="Fehler" 'Die Daten mit Werten "Fehler" in Spalte 5 filtern
             'Sichtbare Zellen in das Blatt "Falsche Vokabeln1" kopieren:
             .Range(.Cells(2, 1), .Cells(.Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy tarWks.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
             If Sheets("Vokabeln").AutoFilterMode Then Range("A1").AutoFilter 'Wenn der Autofilter gesetzt ist, dann Filter abschalten
             'Fomel eintragen
             With tarWks
                 'Formel in Spalte E einfügen:
                 .Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
                         "=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"
             End With
        End With
        'Der einzige Unterschied: Wenn ein x in J18 gesetzt ist, werden die Duplikate im Blatt "Falsche Vokabeln1" entfernt:
        If srcWks.Range("J18") <> "x" Then
             With tarWks
                'Alle doppelten Vokabeln löschen
                .Range("$A$1:$E" & .Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates _
                 Columns:=1, Header:=xlYes
             End With
         End If
        Schutz_an srcWks
        Schutz_an tarWks
        tarWks.Activate
        Set srcWks = Nothing
        Set tarWks = Nothing
        Application.ScreenUpdating = True   'Schaltet den Bildschirm ein
    Else
        MsgBox "OK, die Daten werden nicht übertragen!"
    End If
End Sub
Sub Schutz_aus(wks As Worksheet)
    wks.Unprotect Password:=""
    wks.Columns("A:H").Hidden = False
End Sub
Sub Schutz_an(wks As Worksheet)
    wks.Range("B:B, G:G").EntireColumn.Hidden = True
    wks.Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Du fragst nach einer Erklärung für den folgenden Code:
Code:

Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
"=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"
Dieser stammt von Dir bzw. aus Deinem ursprünglichen Code. Eigentlich solltest Du wissen, was der macht, oder nicht?

__________________

Gruß
Michael
Der Steuerfuzzi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 19.03.2019, 19:03   #12
Quartzlurch
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hallo Michael,

der ist leider nicht von mir. Aber ist schon ok. Danke dir nochmals.

Dir noch einen schönen Abend ��
Quartzlurch ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 20.03.2019, 10:19   #13
Quartzlurch
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hallo Michael,

die beiden Fragezeichen hinter: "Dir noch einen schönen Abend" sollten ein lachendes Smily sein, was ich über die Tastatur eingab.

OK, ich habe jetzt den Code in alle Tabellenblätter eingefügt >vier an der Zahl<, und das funktioniert alles wunderbar, bis auf eine Sache. Wenn ich die doppelten übertragen möchte wird das ausgeführt doch die Spalte "D" ist schreibgeschützt, sodass man die Vokabeln nicht übersetzen kann. Ich habe schon mehrmals die Spalte "D" ab der 2. Zeile ungeschützt eingestellt und abgespeichert doch durch das nächste übertragen sind wieder Zellen unterhalb gesperrt. Die Spalte "D" sollte eigentlich immer ungeschützt sein. Wäre das noch machbar? Sonst funktioniert das tadellos!

Gruß Horst
Quartzlurch ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 21.03.2019, 08:12   #14
Der Steuerfuzzi
MOF Profi
MOF Profi
Standard

Hallo Horst,

das liegt möglicherweise daran, dass einige Zellen in Spalte D als "geschützt" gekennzeichnet sind. Versuch mal in beiden Arbeitsblättern die Spalte D komplett zu markieren und mittels "Zellen formatieren" auf dem Reiter "Schutz" den Haken bei "Gesperrt" zu entfernen (das Kästchen davor muss leer sein).

__________________

Gruß
Michael
Der Steuerfuzzi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 21.03.2019, 08:58   #15
Quartzlurch
Threadstarter Threadstarter
MOF User
MOF User
Standard

Guten Morgen Michael,

Das hatte ich mehrmals versucht, aber nach dem nächsten übertragen waren wieder Zellen gesperrt. Meistens, aber nicht immer, waren soviele Zellen gesperrt, wie ich Datensätze übertragen hatte. Werde mal versuchen die Spalte „D“ im Code nach dem Autofilter als ungeschützt einzubinden. Vielleicht hilft das.

Gruß Horst

P. S.
Dir noch einen schönen Tag!
Quartzlurch ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 21:38 Uhr.



Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.