Народ, помогите с удалением записей из базы, созданной в Excel
Вот здесь коды создания и поиска записей, может кто знает, как стирать найденные записи так, чтобы не оставалось пустой строки
И что имеется ввиду под понятием «возможность просмотра БД»?
Private Sub CommandButton1_Click()
' поиск по Ф
With Sheets("База данных")
' сортировка...
yend = .Cells(65536, 1).End(xlUp).Row
.Columns("A:R").Sort Key1:=.Cells(4, 1), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
' последняя строка
i = 0 ' счетчик строк с одинаковой Ф
Set r1 = .Range(.Cells(4, 1), .Cells(yend, 1)) ' от первой до последней
Set rf = r1.Find(TextBox_FIO.Text, LookIn:=xlValues, LookAt:=xlWhole) ' поиск по Ф
If Not rf Is Nothing Then
y = rf.Row
Do While .Cells(y, 1) = TextBox_FIO.Text
i = i + 1
mes1 = .Cells(y, 1)
mes2 = .Cells(y, 2)
mes3 = .Cells(y, 3)
mes4 = .Cells(y, 4)
mes5 = .Cells(y, 5)
mes6 = .Cells(y, 6)
mes7 = .Cells(y, 7)
mes8 = .Cells(y, 8)
mes9 = .Cells(y, 9)
mes10 = .Cells(y, 10)
mes11 = .Cells(y, 11)
mes12 = .Cells(y, 12)
mes13 = .Cells(y, 13)
mes14 = .Cells(y, 14)
mes15 = .Cells(y, 15)
mes16 = .Cells(y, 16)
mes17 = .Cells(y, 17)
mes18 = .Cells(y, 18)
y = y + 1
Loop
' вывод в форму...
If mes3 = "M" Then
Pol_M.Value = -1
Pol_W.Value = 0
ElseIf mes3 = "W" Then
Pol_W.Value = -1
Pol_M.Value = 0
End If
TextBox_Vozr.Value = mes2
TextBox_Lev_dlina.Value = mes4
TextBox_lev_shir.Value = mes5
TextBox_Lev_Tolw.Value = mes6
TextBox_Prav_Dlina.Value = mes7
TextBox_Prav_Shir.Value = mes8
TextBox_Prav_Tolw.Value = mes9
Label_V_PD_2.Caption = mes10
Label_V_PD_3.Caption = mes11
Label_Prav_Dol.Caption = mes12
Label_V_LD_2.Caption = mes13
Label_V_LD_З.Caption = mes14
Label_Lev_Dol.Caption = mes15
Label_Ob_V_2.Caption = mes16
Label_Ob_V_3.Caption = mes17
Label_V_Ob.Caption = mes18
Else
MsgBox "Данных о " & Me.TextBox_FIO.Text & " нет...", vbCritical, ""
End If
End With
End Sub Private Sub CommandButton2_Click()
' сортируем...
' ищем И,
' если нашли, ищем Возраст,
' запоминаем номер строки...
' если нет такого Им , то запись в конец листа
Application.StatusBar = "Запись, ждите..."
With Sheets("База данных")
yend = .Cells(65536, 1).End(xlUp).Row
' сортировка...
.Columns("A:R").Sort Key1:=.Cells(4, 1), Order1:=xlAscending, _
Key2:=.Cells(4, 2), Order2:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
' последняя строка
yy = yend + 1 ' указатель куда записывать
Set r1 = .Range(.Cells(1, 1), .Cells(yend, 1)) ' от первой до последней
Set rf = r1.Find(Me.TextBox_FIO.Text, LookIn:=xlValues, LookAt:=xlWhole) ' поиск по Ф
If Not rf Is Nothing Then
' такая запись уже есть...
y = rf.Row ' первая с такой Ф
Set r2 = .Range(.Cells(y - 3, 2), .Cells(yend, 2)) ' от первой Ф до последней
Set rf = r2.Find(Me.TextBox_Vozr.Text, LookIn:=xlValues, LookAt:=xlWhole) ' поиск по Возр
If Not rf Is Nothing Then
' такая Ф и возр уже есть...
yy = rf.Row ' строка с такой Ф И О ' меняем указатель куда записывать...
If MsgBox("Данные о " & .Cells(yy, 1) & " " & .Cells(yy, 2) & " " & " уже есть" & " " & "перезаписываем ?", vbQuestion + vbOKCancel, "") = vbCancel Then Exit Sub
End If
End If
End With
Call Записать(yy) ' записать...
MsgBox "Готово", vbInformation, ""
End Sub
Sub Записать(y)
With Sheets("База данных")
If Pol_M.Value = -1 Then
.Cells(y, 3).Value = "M"
ElseIf Pol_W.Value = -1 Then
.Cells(y, 3).Value = "W"
End If
.Cells(y, 1).Value = TextBox_FIO.Text
.Cells(y, 2).Value = TextBox_Vozr.Text
.Cells(y, 4).Value = TextBox_Lev_dlina.Value
.Cells(y, 5).Value = TextBox_lev_shir.Value
.Cells(y, 6).Value = TextBox_Lev_Tolw.Value
.Cells(y, 7).Value = TextBox_Prav_Dlina.Value
.Cells(y, 8).Value = TextBox_Prav_Shir.Value
.Cells(y, 9).Value = TextBox_Prav_Tolw.Value
.Cells(y, 10).Value = Label_V_PD_2.Caption
.Cells(y, 11).Value = Label_V_PD_3.Caption
.Cells(y, 12).Value = Label_Prav_Dol.Caption
.Cells(y, 13).Value = Label_V_LD_2.Caption
.Cells(y, 14).Value = Label_V_LD_З.Caption
.Cells(y, 15).Value = Label_Lev_Dol.Caption
.Cells(y, 16).Value = Label_Ob_V_2.Caption
.Cells(y, 17).Value = Label_Ob_V_3.Caption
.Cells(y, 18).Value = Label_V_Ob.Caption
End With
Application.StatusBar = ""
End Sub
