Как перенести данные из одного входного листа Excel в лист базы данных Excel? (Системный дизайн)

Question

У меня есть этот лист ввода здесь , в который вводятся данные и из которого мне нужно перенести некоторые поля. Эта форма должна заполняться каждый день, а дата в углу должна быть изменена.

Кроме того, у меня есть эти Лист базы данных для произведенных в реальности и Лист базы данных для установок машины и я использую дату в качестве ключа. Однако сначала я хочу проверить, есть ли эти даты в базе данных реального производства, чтобы исключить дубликаты перед тем, как это произойдет. Логика c - если уже существует та же дата, пользователь может выбрать, перезаписать ее или прекратить процесс, и, если такой даты нет, перенести данные в следующую свободную строку. Код для двух из трех БД приведен ниже. Как изменить и настроить (вероятно, второй l oop), чтобы он не перезаписывал всю БД последним входным значением. Также были бы оценены улучшения дизайна баз данных.

Sub TransferData()

'Turning off all screen updating
Application.ScreenUpdating = False

Dim PA As Worksheet
Dim LT As Worksheet
Dim SDB As Worksheet
Dim PlanB As Worksheet
'    Dim PlanM As Worksheet
'    Dim PlanC As Worksheet
'    Dim PlanN As Worksheet
Dim i As Long

'Setting names for the sheets that we will use at this macro
Set PA = Sheets("ProdActual DB")
Set LT = Sheets("LT Delays DB")
Set SDB = Sheets("Setup DB")
Set PlanB = Sheets("PlanB")  
Dim Answer As String
Dim MyNote As String

'Creating a message box where the user will select if he wants to proceed or not with the Data Transfer
MyNote = ("Do you want to proceed with data transfer?")
Answer = MsgBox(MyNote, vbQuestion + vbYesNo, "Data transfer")
If Answer = vbNo Then
    Range("E8").Select
    GoTo 12
Else

    'Checking if the user has entered a Date in the given field.
    'If not the code brings up a msgbox asking him to enter one, selects the date's cell and stops running
    If PlanB.Cells(4, 20) = 0 Then
        MsgBox ("You haven't entered a date. Please enter a date!")
        PlanB.Activate
        PlanB.Cells(4, 9).Select
        GoTo 12
    End If

    'We loop in the database searching each row
    For i = 7 To 700
        'Making the code to search only the rows that data exist
        PA.Activate
        If PA.Cells(i, 2) = "" Then
            GoTo 11
            i = 700

            'Searching if the current date and its data has already been transfered and if
            'it's the case, brings up a message box asking the user to choose if he wants to
            'overwrite the data
        ElseIf PlanB.Cells(4, 20) = PA.Cells(i, 2) Then

            Dim Msg, Style, Response, MyString 'Title, Help, Ctxt
            Msg = "Date" & "" & PA.Cells(4, 20) & " " & "exists already in the database. Are you sure you want to overwrite the existing data for this date?" ' Define message.
            Style = vbYesNo + vbDefaultButton2 + vbExclamation ' Define buttons.

            Response = MsgBox(Msg, Style)
            If Response = vbYes Then         ' User chose Yes.
                MyString = "YES"             ' Perform some action.
                'Creating a loop to go through the different entries in the follow-up sheet

                For k = 11 To 25
                    'Check for blanks and if it's product
                    If PlanB.Cells(k, 2) <> "" And Left(PlanB.Cells(k, 2), 5) = "ROUND" Then

                        PA.Cells(i, 2) = PlanB.Cells(4, 20) 'transfer the date in the production actual DB
                        PA.Cells(i, 3) = PlanB.Cells(3, 20) 'transfer the line
                        PA.Cells(i, 4) = PlanB.Cells(2, 20) 'transfer the shift
                        PA.Cells(i, 5) = PlanB.Cells(k, 3) 'product code
                        PA.Cells(i, 7) = PlanB.Cells(k, 14) 'produced qty
                        PA.Cells(i, 8) = PlanB.Cells(k, 13) - PlanB.Cells(k, 12) 'duration of the run
                        PA.Cells(i, 9) = PA.Cells(i, 8) - PlanB.Cells(k, 9) 'total difference planned/actual

                        'If it is not product and it is not blank then it goes as a changeover/setup
                    ElseIf PlanB.Cells(k, 2) <> "" Then
                        SDB.Cells(i, 2) = PlanB.Cells(4, 20) 'transfer the date in the Setup DB
                        SDB.Cells(i, 3) = PlanB.Cells(3, 20) 'transfer the line
                        SDB.Cells(i, 4) = PlanB.Cells(2, 20) 'transfer the shift
                        SDB.Cells(i, 5) = PlanB.Cells(k, 2) 'transfer the description
                        SDB.Cells(i, 6) = PlanB.Cells(k, 9) 'standard duration

                    End If
                Next k

            ElseIf Response = vbNo Then      ' User chose No.
                MyString = "NO"              ' Perform some action.
                PlanB.Activate
                PlanB.Cells(4, 20).Select
                GoTo 12
            End If
        End If
    Next i
 11

Application.ScreenUpdating = True

 12

End Sub

Answer 1

Используйте метод WorksheetFunction.Match , чтобы сопоставить дату с диапазоном. Если он совпадает, возвращается номер совпадения (так что вы можете перезаписать эту строку), если он не совпадает, выдается ошибка (в этом случае вам нужно вставить новую строку

. Вот пример как с этим справиться:

Dim MatchedRow As Double
MatchedRow = 0 'initialize
On Error Resume Next 'disable error reporting
MatchedRow = Application.WorksheetFunction.Match(Lookup_Value, Lookup_array, 0)
On Error Goto 0 'enable error reporting

'if Match errored then MatchedRow will still be the initial value 0
If MatchedRow = 0 Then
    'Nothing matched add new row
Else
    'otherwise use MatchedRow to access the cells in that row to override your data for that date
    YourSheet.Cells(MatchedRow, "A").Value = "override row")
End If

• Lookup_Value - ваша дата
• Lookup_array - диапазон, который вы ищете для своей даты
• YourSheet потребности заменяется ссылкой на ваш лист.

Для получения дополнительной информации об обработке ошибок: Обработка ошибок VBA - Полное руководство .