VBA.Mania

Private IdRekordBiezacy As Integer
Private RekordNowy As Boolean 'wskażnik dodawania rekordu
Private DaneArk As Worksheet, BuforArk As Worksheet

'adres zakresu Bufora, Wzorca formatu i danych nowych, każdego rekordu danych
'względem pierwszej komórki Bufora,Wzorca,każdego rekordu
Private RekordAdresStr As String

' wypełnić odpowiednio do stanu faktycznego
Const ArkuszDanychNazwa = "Baza1Dane", ArkuszBuforaNazwa = "Baza1Bufor"

' numer wiersza z buforem
Const BuforWiersz = 1

'z tego wiersza będą pobierane formaty komórek dla wiersza bufora i rekordu bazy
'i\lub wartości dla bufora nowego rekordu
'w tych komórkach mogą być formuły np. data bieżąca =DZIŚ()
'uwaga wczytanie daty do TextBoxa może być w formacie amerykańskim ! ale można wpisać w polskim i zapisze w arkuszu dobrze
Const BuforInicjującyWiersz = 2

'BARDZO WAŻNE wg stanu faktycznego wpisać TextBox'y w kolejności odpowiadającej kolumnom w Obszarze danych
Private TBxArr
Private ilePol As Integer

Public Sub BazaInit()
Dim TBxName

  'BARDZO WAŻNE wg stanu faktycznego wpisać w kolejności odpowiadającej kolumnom w Obszarze danych
  TBxArr = Array("TextBox1", "TextBox2", "TextBox10")


  On Error Resume Next
  Set DaneArk = ThisWorkbook.Worksheets(ArkuszDanychNazwa)
  On Error GoTo 0

  'automatyczne założenie arkusza BAZY
  If DaneArk Is Nothing Then
' If MsgBox("brak arkusza danych bazy " & vbCr & "założyć ?", vbOKCancel + vbDefaultButton2 + vbCritical, "test bazy danych") <> vbOK Then
' End
' End If

   Set DaneArk = ThisWorkbook.Worksheets.Add
   DaneArk.Name = ArkuszDanychNazwa
  End If

  On Error Resume Next
  Set BuforArk = ThisWorkbook.Worksheets(ArkuszBuforaNazwa)
    On Error GoTo 0

  'automatyczne założenie arkusza BUFORA
  If BuforArk Is Nothing Then
' If MsgBox("brak arkusza bufora " & vbCr & "założyć ?", vbOKCancel + vbDefaultButton2 + vbCritical, "test bazy danych") <> vbOK Then
' End
' End If
   Set BuforArk = ThisWorkbook.Worksheets.Add
   BuforArk.Name = ArkuszBuforaNazwa
  End If

  ilePol = 0

  For Each TBxName In TBxArr
   ilePol = ilePol + 1
   With Me.Controls(TBxName)
    .ControlSource = ""
    .ControlSource = BuforArk.Cells(BuforWiersz, ilePol).Address(rowabsolute:=False, columnabsolute:=False, external:=True)
   End With
  Next

  RekordAdresStr = BuforArk.Cells(BuforWiersz, 1).Resize(, ilePol).Address(rowabsolute:=False, columnabsolute:=False)

  If F_RekordowIle < 1 Then
   UtworzNowyRekord
  Else
   F_OdczytBazyDoBufora 1
  End If
  PrzelaczTylkoNowy RekordNowy
End Sub

Private Function UsunRekord()
Dim IdRekordu
If RekordNowy Then Exit Function

If IdRekordBiezacy > 0 And IdRekordBiezacy <= F_RekordowIle Then

  DaneArk.Rows(IdRekordBiezacy).Delete
  IdRekordu = F_RekordowIle

  If IdRekordu < 1 Then
   UtworzNowyRekord
   IdRekordBiezacy = 0
  ElseIf IdRekordBiezacy <= IdRekordu Then
   IdRekordu = IdRekordBiezacy
   F_OdczytBazyDoBufora IdRekordu
  Else
   F_OdczytBazyDoBufora IdRekordu
  End If
End If
End Function

Function UtworzNowyRekord()

RekordNowy = True

BuforArk.Cells(BuforInicjującyWiersz, 1).Range(RekordAdresStr).Copy
BuforArk.Cells(BuforWiersz, 1).Range(RekordAdresStr).PasteSpecial xlPasteFormats
BuforArk.Cells(BuforWiersz, 1).Range(RekordAdresStr).PasteSpecial xlPasteValues

  On Error Resume Next
   Me.RekordLabel.Caption = "NOWY/" & F_RekordowIle
  On Error GoTo 0

End Function

Function F_OdczytBazyDoBufora(Optional ByVal IdRekordu) As Integer

If IsMissing(IdRekordu) Then IdRekordu = IdRekordBiezacy

If IdRekordu < 1 Or IdRekordu > F_RekordowIle Then
  Exit Function
End If

BuforArk.Cells(BuforInicjującyWiersz, 1).Range(RekordAdresStr).Copy
BuforArk.Cells(BuforWiersz, 1).Range(RekordAdresStr).PasteSpecial xlPasteFormats
DaneArk.Cells(IdRekordu, 1).Range(RekordAdresStr).Copy
BuforArk.Cells(BuforWiersz, 1).Range(RekordAdresStr).PasteSpecial xlPasteValues

F_OdczytBazyDoBufora = IdRekordu
SetRekordSayBiezacy IdRekordu
RekordNowy = False

End Function

Private Function F_ZpiszBfuorDoBazy()
Dim IdRekordu As Integer

If RekordNowy Then
  IdRekordu = F_RekordowIle + 1
ElseIf IdRekordBiezacy < 1 Or IdRekordBiezacy > F_RekordowIle Then
  Exit Function
Else
  IdRekordu = IdRekordBiezacy
End If
BuforArk.Cells(BuforInicjującyWiersz, 1).Range(RekordAdresStr).Copy
DaneArk.Cells(IdRekordu, 1).Range(RekordAdresStr).PasteSpecial xlPasteFormats
BuforArk.Cells(BuforWiersz, 1).Range(RekordAdresStr).Copy
DaneArk.Cells(IdRekordu, 1).Range(RekordAdresStr).PasteSpecial xlPasteValues

F_ZpiszBfuorDoBazy = IdRekordu
SetRekordSayBiezacy IdRekordu
RekordNowy = False
End Function

Private Function F_RekordowIle() As Integer
'wyszukanie ostatniego wiersza z danymi , jeżeli arkusz pusty będzie 0
With DaneArk.Cells
  On Error Resume Next
  F_RekordowIle = .Find("*", .Cells(.Rows.Count, .Columns.Count), xlValues, xlWhole, xlByRows, xlPrevious).Row
  On Error GoTo 0
End With

End Function

Function SetRekordSayBiezacy(ByVal IdRekordu)
'jeżeli założona zostanie etykieta RekordLabel w niej będzie wyświetlana buchalteria rekordów
  IdRekordBiezacy = IdRekordu
  On Error Resume Next
   Me.RekordLabel.Caption = IdRekordBiezacy & "/" & F_RekordowIle
  On Error GoTo 0
End Function

Private Sub PrzelaczTylkoNowy(IsNowy As Boolean)
If Not IsNowy Then
  Me.Następny.Enabled = True
  Me.Poprzedni.Enabled = True
  Me.Dodaj.Caption = "Dodaj"
  Me.Usuń.Caption = "Usuń"
Else
  Me.Następny.Enabled = False
  Me.Poprzedni.Enabled = False
  Me.Dodaj.Caption = "Zapisz nowy"
  Me.Usuń.Caption = "Anuluj nowy"
End If
End Sub

Private Sub Dodaj_Click()

If RekordNowy Then
  F_ZpiszBfuorDoBazy
Else
  F_ZpiszBfuorDoBazy
  UtworzNowyRekord
End If
PrzelaczTylkoNowy RekordNowy
End Sub

Private Sub Następny_Click()
Dim IdRekordu
  IdRekordu = IdRekordBiezacy + 1
  F_ZpiszBfuorDoBazy
If IdRekordu > 0 And IdRekordu <= F_RekordowIle Then
  F_OdczytBazyDoBufora IdRekordu
End If
End Sub

Private Sub Poprzedni_Click()
Dim IdRekordu
IdRekordu = IdRekordBiezacy - 1
F_ZpiszBfuorDoBazy
If IdRekordu > 0 Then
  F_OdczytBazyDoBufora IdRekordu
End If

End Sub

Private Sub Usuń_Click()
If RekordNowy Then
'skasuje znacznik nowy
  F_OdczytBazyDoBufora IdRekordBiezacy
Else
  UsunRekord
End If
PrzelaczTylkoNowy RekordNowy
End Sub