Private Sub Worksheet_Change(ByVal target As Range)
Application.EnableEvents = False
If Intersect(target, Range("F:F")) Is Nothing Then
Exit Sub 'jeśli komorka nie kwalifikuje się do zakresu który ma przenoić makro przenies1 zamyka procedurę
ElseIf target = "TAK" Then 'jesli komorka jest w interesującym mnie zakresie i ma wartosc tak uruchamia makro
Set yestarget = target 'ponieważ zmienna target ma dostęp ustawiony na prywatny muszę ją upublicznić referując ją do innej zmiennej
Call przenies1
End If
Application.EnableEvents = True
End Sub
Public yestarget As Range
Sub przenies1()
'Procedura ma na celu przenoszenie rekordu(wiersza)
'do innego arkusza xls w jego pierszwszy wolny od góry wiersz
'przyjąłem, że kryterium (kolumna) stanowiące podstawę do uruchomienia zdarzenia
'znajduje się w ostatniej kolumnie przenoszonego rekordu.
'(Pamiętaj żeby przypisać zdarzenie Change do arkusza w którym ma uruchomić się makro:
'ja robiłem to sprawdzając w zdarzeniu czy zmieniana komórka znajduje się w określonym zakresie
'(właściwość Intersect) i każąc mu wykonać makro jeżeli target ma określoną wartość)
Dim mycell As Range
Dim mycell_adr As String
Dim zaznaczenie As Range
'Dim zakres As Range
Dim First_empty_row_umowione As Range
Dim data_spotkania As Date
On Error GoTo ERROR_HANDLING 'przejście do obsługi błędów
Application.ScreenUpdating = False
'oznaczenie zakresu tak/nie w kolumnie która stanowi podstawę do skopiowania rekordu
'Set zakres = Range(Range("f1"), Range("f" & Rows.Count).End(xlUp))
'zdefiniowanie komorki z informacją czy umówione spotkanie(TAK/NIE) jako zmiennej mycell
'stanowiącej podstawę przesunięć do arkusza umówione
Set mycell = yestarget
mycell_adr = mycell.Address(True, False)
'przypisanie zakresu kopiowanego rekordu od komorki czy umówiono spotkanie do kolumny A
'w wierszu w którym znajduje się kopiowany rekord
Set zaznaczenie = Range(Range("a" & Right(mycell_adr, Len(mycell_adr) - InStrRev(mycell_adr, "$"))), mycell.Offset(0, -1).Address)
wiersz = Right(mycell_adr, Len(mycell_adr) - InStrRev(mycell_adr, "$"))
'dodakowa weryfikacja czy napewno komorka zmienna mycell ma poprawną wartość
If mycell <> "" And mycell = "TAK" Then
If MsgBox _
(Prompt:="Czy przenieść rekord z zaplanowanych do kontaktu do umówionych?", _
Buttons:=vbYesNo + vbQuestion, _
Title:="CRM") = vbYes Then
With zaznaczenie
.Select
.Copy
End With
'Otwieramy arkusz do którego mają być skopiowane dane
'ustawiamy sie w pierwszym wolnym wierszu kolumny A
'+dodajemy datę spotkania w formacie yyyy/mm/dd
Sheets("Arkusz2").Select
Set First_empty_row_umowione = Range("a" & Rows.Count).End(xlUp).Offset(1, 0) 'zaznaczenie wiersza do którego przeklejamy rekord
First_empty_row_umowione.Select
ActiveSheet.Paste
METTING_DATE:
data_spotkania = InputBox(Prompt:="Podaj datę spotkania (yyyy/mm/dd)", Title:="CRM")
First_empty_row_umowione.Offset(0, 5).Value = data_spotkania 'wkleja datę spotkania w komorkę po prawo od skopiowanego rekordu
Sheets("Arkusz1").Select
If MsgBox _
(Prompt:="Czy usunąć rekord z zaplanowanych do kontaktu?", _
Buttons:=vbYesNo + vbQuestion, _
Title:="CRM") = vbYes Then 'usunięcie wiersza z arkusza planowania
With Rows(wiersz)
.Select
.Delete Shift:=xlUp
End With
Else
Application.CutCopyMode = False 'odznaczamy zakres kopiowanego rekordu
End If
End If
End If
Range("a1").Select
Exit Sub
ERROR_HANDLING: 'obsługa błędów
Select Case Err.Number
Case 13 'niezgodność typów
Application.EnableEvents = True
If MsgBox(Prompt:=Err.Number & " " & Err.Description & vbNewLine & "Czy na pewno nie chcesz wprowadzać daty spotkania?", _
Buttons:=vbCritical + vbYesNo, Title:="error") = vbNo Then
GoTo METTING_DATE
Else
Resume Next
End If
Case Else
Application.EnableEvents = True ' włączenie eventów, które wyłączyłem w zdarzeniu Change
MsgBox Prompt:="Błąd " & Err.Number & vbNewLine & vbNewLine & "Opis " & vbNewLine & Err.Description, _
Buttons:=vbCritical + vbOKOnly, Title:="error"
End Select
Application.ScreenUpdating = True
End Sub