Поиск в диапазоне дат + копировать строку на новый лист, если она действительна

Question

Я пытаюсь помочь своему коллеге упростить поиск по нашим данным (с датами истечения срока действия) и получить этот обзор, который соответствует профилю (диапазон = сегодня + 21 день).Но я новичок в VBA. Я немного поработал со старым (предыдущей фирмой) моим коллегой, поэтому я знаю, что это возможно, но мне просто не хватает знаний ..

Я пытаюсь настроить этоследующая последовательность:

• Sub 1 - это работает

Запрос, какой файл нужно проверить (чтобы можно было выбрать мастер-лист)

• Sub 2

  1. Создание нового файла для сохранения данных в
  2. Копирование строки A из главной таблицы в новый файл.
  3. Поиск столбца B для текущей даты+ 21 день, если найден -> скопировать эту строку в следующую пустую строку в новом файле

• Sub 3 Сохранить вновь созданный файл в предварительно определенном каталоге под именем: Week [currentчисло дней недели с понедельника] - [фиксированное имя], если в строке B нового файла не найдено данных.Показывать всплывающее окно без даты истечения срока действия в течение 21 дня с текущей даты.

Sub 1: Working

Private Sub Test_Schou067_Part_1 () Dim intChoice As String Dim MasterWB As Workbook Dim ThisWBКак книга Dim longRow Как долго Dim SaveAsFileName As String

intChoice = Application.FileDialog (msoFileDialogFilePicker) .Show Если intChoice = 0, то MsgBox («Файл не выбран, процесс отменен») Выход из Sub End If End Sub

SUB 2 - не работает

Private Sub Test_Schou067_Part_2 ()

Set WBMacro = ActiveWorkbook ChDir (WBMacro.Path)

CreateFolder (WBMacro.Path & "\"& Year (Now)) CreateFolder (WBMacro.Path &" \ "& Year (Now) &" \ Week "& WorksheetFunction.WeekNum (Now, vbMonday))

ActiveWorkbook.SaveAs Имя файла:= (WBMacro.Path & "\" & Year (Now) & "\ Week" & WorksheetFunction.WeekNum (Now, vbMonday) & "\ SOP DATA \" & "Скоро истекает SOP (ы)" & ".xlsx"), ConflictResolution: = Excel.XlSaveConflictResolution.xlLocalSessionChangesActiveWorkbook.Close

'здесь я хочу сохранить документ' Cal sub

End Sub

Answer 1

этот код должен делать то, что вы хотите. Логика сравнения дат может отличаться в зависимости от формата даты. Вы можете попробовать и дать мне знать.

Вы можете открыть новый Excel для запуска этого кода.

Private Sub Test_Schou067()
Dim intChoice       As String
Dim MasterWB        As Workbook
Dim ThisWB          As Workbook
Dim longRow         As Long
Dim SaveAsFileName As String

intChoice = Application.FileDialog(msoFileDialogFilePicker).Show
If intChoice = 0 Then
    MsgBox ("No File Selected, Process Cancelled")
    Exit Sub
End If

Set ThisWB = ActiveWorkbook
Set MasterWB = Workbooks.Open(Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1))
MasterWB.Sheets(1).Range("A1").EntireRow.Copy ThisWB.Sheets(1).Range("A1")
MasterWB.Sheets(1).Activate

For longRow = 2 To Cells(Rows.Count, 24).Row
    If DateValue(Cells(longRow, 24)) = DateValue(Now + 21) Then
        Cells(Rows.Count, 24).EntireRow.Copy ThisWB.Sheets(1).Cells(ThisWB.Sheets(1).Cells(Rows.Count, 24).End(xlUp).Row + 1, 1)
    End If

Next

MasterWB.Close
SaveAsFileName = Application.GetSaveAsFilename(filefilter:="Excel File.(*.xlsx), *xlsx")
ThisWB.SaveAs (SaveAsFileName)


End Sub