VBA Code in freigegebener Tabelle
02.03.2020 08:17:55
Stefan
Ich hätte da mal ein Problemchen. Ich habe hier eine Tabelle welche im nicht Freigegebenen Modus funktioniert. Wenn ich die Tabelle Frei gebe kommt beim kopieren von Zeilen(Zellen) folgende Fehlermeldung und er kopiert nicht.
Benutzerdefinierte Anwendung oder Objekt benutzerdefinierte Fehler.
Leider kann ich nicht debuggen um zu schauen wo es hakt.
Hier der Code dieses Blattes. Hat jemand eine Idee was da faul sein könnte?
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim lngRow As Long
If Not Intersect(Target, Range("AG4:AP250")) Is Nothing Then
Cancel = True
Select Case Target.Column
Case 33
Cells(Target.Row, 1) = 2
Target = Now
Case 34
Cells(Target.Row, 1) = 3
Target = Now
Case 35
Cells(Target.Row, 1) = 4
Target = Now
Case 36
Target = Now
Case 37
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.FilterMode Then
ws.ShowAllData
End If
Next ws
If MsgBox("Willst du wirklich dieses Projekt an den Einkauf übergeben?", _
vbQuestion Or vbOKCancel, "Abfrage") = vbOK Then
Cells(Target.Row, 1) = 5
Target = Now
With Worksheets("Einkauf")
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Cells(Target.Row, 1).Resize(1, 41).Copy .Cells(lngRow, 1)
Target.Offset(, -36).Resize(, 41).Copy .Rows(lngRow)
'Target.Offset(, -36).Resize(, 41).Delete
End With
End If
Case 42
For Each ws In ActiveWorkbook.Worksheets
If ws.FilterMode Then
ws.ShowAllData
End If
Next ws
If MsgBox("Willst du wirklich dieses Projekt ins Archiv übergeben?", _
vbQuestion Or vbOKCancel, "Abfrage") = vbOK Then
With Worksheets("Archiv")
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Cells(Target.Row, 1).Resize(1, 41).Copy .Cells(lngRow, 1)
Target.Offset(, -41).Resize(, 41).Copy .Rows(lngRow).Cells(1, 1).Resize(1, _
_
41)
.Rows(lngRow).Cells(1, 1).Resize(1, 41).FormatConditions.Delete
'Target.Offset(, -40).Resize(, 41).Copy .Rows(lngRow)
Target.Offset(, -41).Resize(, 41).Delete
End With
End If
Case 41
For Each ws In ActiveWorkbook.Worksheets
If ws.FilterMode Then
ws.ShowAllData
End If
Next ws
If MsgBox("Willst du wirklich dieses Projekt an die Produktion übergeben? _
_
Sind wirklich alle Felder ausgefüllt? Stimmen die Produktionszeiten?", _
vbQuestion Or vbOKCancel, "Abfrage") = vbOK Then
Cells(Target.Row, 1) = 7
Target = Now
With Worksheets("Klemmenfertigung")
If Cells(Target.Row, 8) = "IV" Then
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Cells(Target.Row, 1).Resize(1, 41).Copy .Cells(lngRow, 1)
Target.Offset(, -40).Resize(, 41).Copy .Rows(lngRow).Cells(1, 1).Resize(1, _
_
41)
.Rows(lngRow).Cells(1, 1).Resize(1, 41).FormatConditions.Delete
'Target.Offset(, -40).Resize(, 41).Copy .Rows(lngRow)
'Target.Offset(, -36).Resize(, 41).Delete
End If
End With
With Worksheets("Klemmenfertigung")
If Cells(Target.Row, 8) = "HV" Then
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Cells(Target.Row, 1).Resize(1, 41).Copy .Cells(lngRow, 1)
Target.Offset(, -40).Resize(, 41).Copy .Rows(lngRow).Cells(1, 1).Resize(1, _
_
41)
.Rows(lngRow).Cells(1, 1).Resize(1, 41).FormatConditions.Delete
'Target.Offset(, -36).Resize(, 41).Delete
End If
End With
With Worksheets("Lager")
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Cells(Target.Row, 1).Resize(1, 41).Copy .Cells(lngRow, 1)
Target.Offset(, -40).Resize(, 41).Copy .Rows(lngRow).Cells(1, 1).Resize(1, _
_
41)
.Rows(lngRow).Cells(1, 1).Resize(1, 41).FormatConditions.Delete
'Target.Offset(, -36).Resize(, 41).Delete
End With
With Worksheets("Aufbau")
If Cells(Target.Row, 8) = "IV" Then
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Cells(Target.Row, 1).Resize(1, 41).Copy .Cells(lngRow, 1)
Target.Offset(, -40).Resize(, 41).Copy .Rows(lngRow).Cells(1, 1).Resize(1, _
_
41)
.Rows(lngRow).Cells(1, 1).Resize(1, 41).FormatConditions.Delete
'Target.Offset(, -36).Resize(, 41).Delete
End If
End With
With Worksheets("IV")
If Cells(Target.Row, 8) = .Name Then
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Cells(Target.Row, 1).Resize(1, 41).Copy .Cells(lngRow, 1)
Target.Offset(, -40).Resize(, 41).Copy .Rows(lngRow).Cells(1, 1).Resize(1, _
_
41)
.Rows(lngRow).Cells(1, 1).Resize(1, 41).FormatConditions.Delete
'Target.Offset(, -36).Resize(, 41).Delete
End If
End With
With Worksheets("HV")
If Cells(Target.Row, 8) = .Name Then
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Cells(Target.Row, 1).Resize(1, 41).Copy .Cells(lngRow, 1)
Target.Offset(, -40).Resize(, 41).Copy .Rows(lngRow).Cells(1, 1).Resize(1, _
_
41)
.Rows(lngRow).Cells(1, 1).Resize(1, 41).FormatConditions.Delete
'Target.Offset(, -36).Resize(, 41).Delete
End If
End With
With Worksheets("MSR")
If Cells(Target.Row, 8) = .Name Then
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Cells(Target.Row, 1).Resize(1, 41).Copy .Cells(lngRow, 1)
Target.Offset(, -40).Resize(, 41).Copy .Rows(lngRow).Cells(1, 1).Resize(1, _
_
41)
.Rows(lngRow).Cells(1, 1).Resize(1, 41).FormatConditions.Delete
'Target.Offset(, -36).Resize(, 41).Delete
End If
End With
With Worksheets("Prüffeld")
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Cells(Target.Row, 1).Resize(1, 41).Copy .Cells(lngRow, 1)
Target.Offset(, -40).Resize(, 41).Copy .Rows(lngRow).Cells(1, 1).Resize(1, _
_
41)
.Rows(lngRow).Cells(1, 1).Resize(1, 41).FormatConditions.Delete
'Target.Offset(, -36).Resize(, 41).Delete
End With
With Worksheets("Gesamtübersicht")
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Cells(Target.Row, 1).Resize(1, 41).Copy .Cells(lngRow, 1)
Target.Offset(, -40).Resize(, 41).Copy .Rows(lngRow).Cells(1, 1).Resize(1, _
_
41)
.Rows(lngRow).Cells(1, 1).Resize(1, 41).FormatConditions.Delete
'Target.Offset(, -36).Resize(, 41).Delete
End With
With Worksheets("Lieferung")
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'Cells(Target.Row, 1).Resize(1, 41).Copy .Cells(lngRow, 1)
Target.Offset(, -40).Resize(, 41).Copy .Rows(lngRow).Cells(1, 1).Resize(1, _
_
41)
.Rows(lngRow).Cells(1, 1).Resize(1, 41).FormatConditions.Delete
'Target.Offset(, -36).Resize(, 41).Delete
End With
End If
Case Else
End Select
End If
End Sub