делать до тех пор, пока раздел не будет повторяться

Question

У меня есть пользовательская форма, которая предназначена для подачи данных на лист Excel, но все работает, кроме серийного номера. он повторяет только второй раз после этого, он возвращает одинаковый серийный номер для каждой записи. Я не знаю, где ошибка. Пожалуйста, исправьте этот код.

Private Sub cmdSub_Click() 
Dim i As Integer 
'position cursor in the correct cell A2 
Range("A2").Select 
i = 1 'set as the first it 
'validate first three controls have been entered... 
If srv.txtTo.Text = Empty Then 'SRV no. for to 
MsgBox "Please Enter SRV NO.To", vbInformation 
srv.txtTo.SetFocus 'position cursor to try again 
Exit Sub 'terminate here - why continue? 
End If 

If srv.txtFrom.Text = Empty Then 'SRV no. for to 
MsgBox "Please Enter SRV NO.From", vbInformation 
srv.txtFrom.SetFocus 'position cursor to try again 
Exit Sub 'terminate here - why continue? 
End If 

If srv.txtLoc.Text = Empty Then 'SRV no. for to 
MsgBox "Please Enter SRV NO.To", vbInformation 
srv.txtLoc.SetFocus 'position cursor to try again 
Exit Sub 'terminate here - why continue? 
End If 

'if all the above are false (OK) then carry on. 
'check to see the next available blank row start at cell A2 
Do Until ActiveCell.Value = Empty 
    ActiveCell.Offset(1, 0).Select 'move down 1 row 
    i = 1 + 1 'keep a count of the ID for later use 
Loop 

'populate the new data values into the 'test' worksheet. 
ActiveCell.Value = i 'next ID Number 
ActiveCell.Offset(0, 1).Value = srv.txtTo.Text 'set col B 
ActiveCell.Offset(0, 2).Value = srv.txtFrom.Text 'set cl c 
ActiveCell.Offset(0, 3).Value = srv.txtLoc.Text 'set col c 

'clear down the values ready for the next record entry 
srv.txtTo.Text = Empty 
srv.txtFrom.Text = Empty 
srv.txtLoc.Text = Empty 

srv.txtTo.SetFocus ' positions the cursor for next work 

End Sub

Answer 1

Вы должны забыть цикл и использовать End (xlUp), чтобы получить первую доступную пустую ячейку. Я также изменил метод получения нового идентификатора, так как ваш старый метод может вызвать дубликаты при удалении строки.

Private Sub cmdSub_Click() 

'validate first three controls have been entered... 
If srv.txtTo.Text = Empty Then 'SRV no. for to 
MsgBox "Please Enter SRV NO.To", vbInformation 
srv.txtTo.SetFocus 'position cursor to try again 
Exit Sub 'terminate here - why continue? 
End If 

If srv.txtFrom.Text = Empty Then 'SRV no. for to 
MsgBox "Please Enter SRV NO.From", vbInformation 
srv.txtFrom.SetFocus 'position cursor to try again 
Exit Sub 'terminate here - why continue? 
End If 

If srv.txtLoc.Text = Empty Then 'SRV no. for to 
MsgBox "Please Enter SRV NO.To", vbInformation 
srv.txtLoc.SetFocus 'position cursor to try again 
Exit Sub 'terminate here - why continue? 
End If 

'Get the first available blank cell in column A. 
With Range("A" & Rows.Count).End(xlUp).Offset(1) 
    'populate the new data values into the 'test' worksheet. 
    .Value = WorksheetFunction.Max(Range("A:A")) + 1 'next ID Number 
    .Offset(0, 1).Value = srv.txtTo.Text 'set col B 
    .Offset(0, 2).Value = srv.txtFrom.Text 'set cl c 
    .Offset(0, 3).Value = srv.txtLoc.Text 'set col c 
End With 

'clear down the values ready for the next record entry 
srv.txtTo.Text = Empty 
srv.txtFrom.Text = Empty 
srv.txtLoc.Text = Empty 

srv.txtTo.SetFocus ' positions the cursor for next work 
End Sub