Fenster springen untereinander

Hallo Sylvie,

danke für die Rückmeldung.

Sie können diese Fragen im TechNet-Forum stellen, meine Kollegen dort haben mehr Erfahrung in diesem Bereich.

Wir freuen uns auf Ihr Feedback.

LG

AEG

Hallo Sylvie,

sehr wahrscheinlich arbeitest du mit SELECT und aktivierst damit die 2. Instanz.

Poste mal deinen Code zum Kopieren.

Claus

hat jetzt fast 10 Jahre funktionniert bis heute

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next

Application.OnKey "~", ""
Application.OnKey "{ENTER}", ""

Dim KeyCells As Range
Dim SourceWorkbook As String
Dim TargetWorkbook As String
Dim SourceSheet As String
Dim TargetSheet As String
Dim SourceCol As Integer

'=========== CELL RANGE ============

Set KeyCells = Range("E3:E1000")

'===================================

'========== TARGET FILE ============

TargetWorkbook = "Comptes.xlsx"

'===================================

'========= Source Col ==============

SourceCol = 5

'===================================

SourceWorkbook = ThisWorkbook.Name

SourceSheet = ActiveSheet.Name
SourceRow = ActiveCell.Row

If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
If Not IsEmpty(currentRowValue) Or Target.Value <> "" Then
TargetSheet = Target.Value
If TargetSheet <> "" Then
Call SetValues(SourceWorkbook, SourceSheet, TargetWorkbook, TargetSheet, SourceRow, SourceCol)
End If
End If
End If
End Sub

Sub SetValues(SourceWorkbook, SourceSheet, TargetWorkbook, TargetSheet, SourceRow, SourceCol)
On Error Resume Next
Dim Workbook As String, Worksheet As String
Dim Field As String, Target As String

Dim rowCount As Integer, currentRow As Integer
Dim currentRowValue As String

Workbook = Application.ActiveWorkbook.Name

Field = ActiveCell.Address
Target = TargetValue
ActiveCell.EntireRow.Select

rowCount = 10000

If WorksheetFunction.CountA(Selection) = 0 Then
MsgBox ("Source is empty line!")
Exit Sub
End If

Selection.Copy

Windows(TargetWorkbook).Activate
If Err.Number <> 0 Then
TargetWorkbook = Replace(TargetWorkbook, ".xlsm", "")
TargetWorkbook = Replace(TargetWorkbook, ".xlsx", "")
TargetWorkbook = Replace(TargetWorkbook, ".xls", "")
Err.Number = 0
Windows(TargetWorkbook).Activate
If Err.Number <> 0 Then
MsgBox ("Comptes is not open or cannot be accessed!")
Exit Sub
End If
End If

Sheets(CStr(TargetSheet)).Select

If Err.Number <> 0 Then
MsgBox ("Sheet " & TargetValue & " does not exist!")
Exit Sub
End If

For currentRow = 1 To rowCount
currentRowValue = ActiveSheet.Cells(currentRow, SourceCol)
If IsEmpty(currentRowValue) Or currentRowValue = "" Then
ActiveSheet.Cells(currentRow, SourceCol).Select
currentRow = rowCount
End If
Next

ActiveCell.EntireRow.Insert
ActiveSheet.Paste
Workbooks(Workbook).Worksheets(Worksheet).Activate
Range(Field).Select
Application.CutCopyMode = False


Err.Number = 0
Windows(SourceWorkbook).Activate
If Err.Number <> 0 Then
SourceWorkbook = Replace(SourceWorkbook, ".xlsm", "")
SourceWorkbook = Replace(SourceWorkbook, ".xlsx", "")
SourceWorkbook = Replace(SourceWorkbook, ".xls", "")
Err.Number = 0
Windows(SourceWorkbook).Activate
If Err.Number <> 0 Then
Exit Sub
End If
End If

Sheets(CStr(SourceSheet)).Select

For currentRow = SourceRow To rowCount
currentRowValue = ActiveSheet.Cells(currentRow, SourceCol).Value
If IsEmpty(currentRowValue) Or currentRowValue = "" Then
ActiveSheet.Cells(currentRow, SourceCol).Select
Exit For
End If
Next
ActiveSheet.Cells(currentRow, 1).Select
End Sub

Über die manuell Einrichtung hatte ich ich es auch schon mehrfach probiert.

Nach der Eingabe des Kennwort spring wieder ein Fenster auf in der ich das Kennwort wiederholt eingeben soll.

Dies ebenfalls gemacht und das Fenster zur widerholten Eingabe des Kennworts spring immer wieder auf.

:-(