Ich hab jetzt x Varianten probiert aber nichts funktioniert.
Ich kopiere Daten und füge sie in eine Tabelle ein. Das Ziel wähle ich mitels Inputbox aus. Das Klappt alles wunderbar, nun möchte ich aber das man nur eine Zelle in Spalte F auswählen kann. wenn man was anderes auswählt soll eine MSGbox kommen.
Kann mir bitte einer helfen, ich weiss mir kein Rat mehr.
Hier mal der Code:
Sub Artikel_Kopieren_Türenartikel()
'Kopieren der Materialien in die Möbelspalte mit Abfrage und Kontrolle das die spalten ausgewä _
hlt wurden
Dim objTargetRange As Range, objCopyRange As Range
Dim objRangeCollection As Collection
If TypeOf Selection Is Range Then
Set objCopyRange = Selection
If VerifySelection(objCopyRange) Then
Set objRangeCollection = New Collection
Worksheets("Möbel").Select
Do
objRangeCollection.Add Application.InputBox(Prompt:= _
"Bitte die Zielzelle markieren In Spalte F (Menge).", Title:="Auswahl", _
Type:=8)
If TypeOf objRangeCollection(objRangeCollection.Count) Is Range Then
Set objTargetRange = objRangeCollection(objRangeCollection.Count)
Exit Do
ElseIf IsEmpty(objRangeCollection(objRangeCollection.Count)) Then
Call MsgBox("Objektzuweisung fehlgeschlagen. Bitte nochmal versuchen", _
vbCritical, "Objektfehler")
ElseIf Not objRangeCollection(objRangeCollection.Count) Then
Exit Sub 'cancelbutton pressed
Else
Call MsgBox("Fehler " & CStr(vbObjectError) & vbLf & vbLf & _
"Unbekannter Objektfehler beim Zuweisen eines Bereiches.", _
vbCritical, "Objektfehler")
Exit Sub
End If
Loop
Call objCopyRange.Copy
Call objTargetRange.Cells(1, 1).PasteSpecial(Paste:=xlPasteValues)
If MsgBox("Noch ein Material Auswählen?", vbYesNo Or vbQuestion, "Abfrage") = vbYes _
Then
Sheets("Artikel Türen").Select
Application.CutCopyMode = False
End If
End If
Set objCopyRange = Nothing
Set objTargetRange = Nothing
Set objRangeCollection = Nothing
End If
End Sub
Private Function VerifySelection(ByRef probjCopyRange As Range) As Boolean
Dim lngRow As Long
VerifySelection = True
With probjCopyRange
If Not Intersect(.Cells, Columns("E:m")) Is Nothing Then
If Intersect(.Cells, Columns("E:m")).Count = .Count Then
For lngRow = .Row To .Row + .Rows.Count - 1
If Intersect(.Cells, Range(Cells(lngRow, 5), Cells(lngRow, 13))).Count 9 _
_
Then
Call MsgBox("Bitte nur ganze Zeilen in den Spalten E-M markieren. (Rote _
_
Bereich)", _
vbExclamation, "Hinweis")
VerifySelection = False
Exit For
End If
Next
Else
Call MsgBox("Bitte nur Zellen in den Spalten E-M markieren. (Rote Bereich)", _
vbExclamation, "Hinweis")
VerifySelection = False
End If
Else
Call MsgBox("Bitte nur Zellen in den Spalten E-M markieren. (Rote Bereich)", _
vbExclamation, "Hinweis")
VerifySelection = False
End If
End With
End Function
Hier ist der Bereich wo ich die zeile zum einfügen auswähle inkl. abfragen ob sie Leer ist,...
Worksheets("Möbel").Select
Do
objRangeCollection.Add Application.InputBox(Prompt:= _
"Bitte die Zielzelle markieren In Spalte F (Menge).", Title:="Auswahl", _
Type:=8)
If TypeOf objRangeCollection(objRangeCollection.Count) Is Range Then
Set objTargetRange = objRangeCollection(objRangeCollection.Count)
Exit Do
ElseIf IsEmpty(objRangeCollection(objRangeCollection.Count)) Then
Call MsgBox("Objektzuweisung fehlgeschlagen. Bitte nochmal versuchen", _
vbCritical, "Objektfehler")
ElseIf Not objRangeCollection(objRangeCollection.Count) Then
Exit Sub 'cancelbutton pressed
Else
Call MsgBox("Fehler " & CStr(vbObjectError) & vbLf & vbLf & _
"Unbekannter Objektfehler beim Zuweisen eines Bereiches.", _
vbCritical, "Objektfehler")
Exit Sub
End If
Loop