Witam, próbuję napisać formularz, który będzie dopisywał nowe filmy do już istniejącego arkusza. Chodzi o dodawanie informacji o nowym filmie, czyli wpisanie liczby porządkowej, tytułu, rozmiaru, czasu trwania, lokalizacji i informacji o lektorze/napisach w kolejne nowe wiersze.
1 film = 1 nowy wiersz.
Udało mi się zrobić prawie wszystko, ale jest jeden problem z moim kodem. Otóż ostatni wiersz tabeli (podsumowanie ilościowe formułami) jest w I332. Natomiast sam spis kończy się na ten moment na zakresie E327:K327 i to w wierszach 321-327 powinny być nowe wpisy. Kod albo dodaje poniżej 332 albo cały czas nadpisuje wiersz 319. W tym momencie jest 7 linii wolnych w spisie. Jednak do pierwszej wolnej kod wpisuje dane tylko wtedy gdy ActiveCell.Offset(-5, 0).Select ma taką postać. Każde kolejne uruchomienie kodu nadpisze wartość wcześniej wprowadzoną. Proszę o pomoc w poprawieniu kodu. Kod poniżej
Private Sub UserForm_Initialize()
lokalizacja.List = Array("E:\Filmy", "E:\Filmy\Seriale", "F:\Filmy\Obejrzane")
rozszerzenie.List = Array("AVI", "RMVB")
tlumaczenie.List = Array("Lektor", "Napisy", "Dubbbing", "Polski film")
lokalizacja.ListIndex = -1
rozszerzenie.ListIndex = -1
tlumaczenie.ListIndex = -1
End Sub
Private Sub anuluj_Click()
Unload Me
End Sub
Private Sub dodaj_Click()
Dim lp As Integer
Dim a As Integer
'zapis danych do wybranego arkusza
Worksheets("filmy").Activate
'
'Ustawienie kursora na kolejnej wolnej pozycji wiersza
Range("e4").Select 'kursor na pierwszej komorce arkusza
Selection.End(xlDown).Select ' przesunięcie w dół do ostatniej komórki w kolumnie
ActiveCell.Offset(-1, 0).Select 'wybranie komórki jeden wiersz niżej w tej samej kolumnie
lp = Range(ActiveCell.Address).Row ' numer aktywnej komórki
a = lp - 2 ' wyliczenie kolejnego numeru Lp
'zapis danych do komórek arkusza
Cells(lp, 5).Value = a
Cells(a, 6).Value = UCase(tytul)
Cells(a, 7).Value = UCase(rozmiar)
Cells(a, 8).Value = UCase(czas)
Cells(a, 9).Value = UCase(lokalizacja)
Cells(a, 10).Value = UCase(rozszerzenie)
Cells(a, 11).Value = UCase(tlumaczenie)
Unload Me
End Sub
Nie wszystko jest dla mnie jasne w Twojej wypowiedzi, więc na początek:
'--------------------------------------------------
' Class Module : UserForm1
'--------------------------------------------------
Option Explicit
Const lRowTittle As Long = 4
Const lRowFormulas As Long = 332
Const lLpColumn As Long = 5
'-------------
Private Sub UserForm_Initialize()
With Me
.lokalizacja.List = Array("E:\Filmy", "E:\Filmy\Seriale", "F:\Filmy\Obejrzane")
.rozszerzenie.List = Array("AVI", "RMVB")
.tlumaczenie.List = Array("Lektor", "Napisy", "Dubbbing", "Polski film")
End With
End Sub
Private Sub odajd_Click()
Dim RnSpec As Excel.Range
Dim a As Long
Dim strTytul As String
Set RnSpec = Nothing
Dim lnglastrow As Long
With Me
Select Case True
Case .lokalizacja.ListIndex < 0
MsgBox "Nie wybrano lokalizacji"
Exit Sub
Case .rozszerzenie.ListIndex < 0
MsgBox "Nie wybrano rozszerzenia"
Exit Sub
Case .tlumaczenie.ListIndex < 0
MsgBox "Nie wybrano tlumaczenia"
Exit Sub
Case Len(Trim(.tytul)) = 0
MsgBox "Brak tytułu"
Exit Sub
' ***** ITD... !!
End Select
End With
With Worksheets("filmy")
Set RnSpec = .UsedRange
Set RnSpec = .Range("E" & CStr(lRowFormulas))
lnglastrow = RnSpec.End(XlDirection.xlUp).Row
Select Case lnglastrow
Case Is <= lRowTittle
a = 1
Case Is >= lRowFormulas
MsgBox "wsio wypełnione"
Exit Sub
Case Else
a = .Range("E" & CStr(lnglastrow)).Value + 1
End Select
lnglastrow = lnglastrow + 1
'zapis danych do komorek arkusza
.Cells(lnglastrow, lLpColumn).Resize(, 7) = VBA.Array(a, _
UCase(Trim(Me.tytul.Value)), _
UCase(Me.rozmiar.Value), _
UCase(Me.czas.Value), _
UCase(Me.lokalizacja), _
UCase(Me.rozszerzenie), _
UCase(Me.tlumaczenie))
End With
Set RnSpec = Nothing
End Sub
Jeśli chodzi o ostatnią komórkę być może należałoby wykorzystać:
Public Function LastRow(rng As Excel.Range) As Long
'wg. Ron de Bruin, 5 May 2008
On Error GoTo LastRow_Error
LastRow = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False, _
SearchFormat:=False).Row
'----------------------------------------
LastRow_Exit:
Exit Function
LastRow_Error:
Resume LastRow_Exit
End Function
Lp masz jak widzę wypełnione, ocena wiersza w tej sytucji po kolumnie F, nie przewidujesz sytacji gdy będzie wiecej filmów? ???
Option Explicit
Const lRowTittle As Long = 2 ' 4
Const lRowFormulas As Long = 328 ' 332
Const lLpColumn As Long = 5
Private Sub dodaj_Click()
Dim RnSpec As Excel.Range
Dim strTytul As String
Set RnSpec = Nothing
Dim lnglastrow As Long
With Me
Select Case True
Case .lokalizacja.ListIndex < 0
MsgBox "Nie wybrano lokalizacji"
Exit Sub
Case .rozszerzenie.ListIndex < 0
MsgBox "Nie wybrano rozszerzenia"
Exit Sub
Case .tlumaczenie.ListIndex < 0
MsgBox "Nie wybrano tlumaczenia"
Exit Sub
Case Len(Trim(.tytul)) = 0
MsgBox "Brak tytułu"
Exit Sub
' ***** ITD... !!
End Select
End With
With Worksheets("filmy")
Set RnSpec = .UsedRange
'Set RnSpec = .Range("E" & CStr(lRowFormulas))
Set RnSpec = .Range("F" & CStr(lRowFormulas))
lnglastrow = RnSpec.End(XlDirection.xlUp).Row
If lnglastrow >= lRowFormulas Then
MsgBox "wsio wypełnione"
Exit Sub
End If
lnglastrow = lnglastrow + 1
'zapis danych do komorek arkusza
.Cells(lnglastrow, lLpColumn + 1).Resize(, 6) = VBA.Array(UCase(Trim(Me.tytul.Value)), _
UCase(Me.rozmiar.Value), _
UCase(Me.czas.Value), _
UCase(Me.lokalizacja), _
UCase(Me.rozszerzenie), _
UCase(Me.tlumaczenie))
End With
Set RnSpec = Nothing
End Sub
