Question

我正在尝试帮助我的同事更轻松地搜索我们的数据（具有到期日期），并获得适合个人资料的概述（范围=今天+21天）。但是我是VBA的新手，我和我的一个老同事（以前的公司）做了一些工作，所以我知道有可能，但我只是缺少知识。

我要设置的顺序如下：

Sub 1-正常工作

询问需要检查哪个文件（以便可以选择母版纸）

Sub 2
1. 创建新文件以将数据保存在其中
2. 将A行从母版复制到新文件。
3. 在B列中搜索当前日期+ 21天如果找到->将该行复制到新文件中的下一个空行
Sub 3 如果在新文件的B行中没有找到数据，则将新创建的文件保存在预定目录下的名称为：Week [从星期一算起的当前星期数]-[固定名称]。从当前日期起21天内显示没有弹出的到期日期。

Sub 1：工作中

私人子测验_Schou067_Part_1（）昏暗intChoice作为字符串 Dim MasterWB作为工作簿将此工作簿调暗为工作簿昏暗的长排昏暗的SaveAsFileName作为字符串

intChoice = Application.FileDialog（msoFileDialogFilePicker）.Show 如果intChoice = 0，则 MsgBox（“未选择文件，已取消进程”）退出子万一结束

SUB 2-不起作用

私人子Test_Schou067_Part_2（）

设置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 \”＆“ Soon to SOP“和” .xlsx“过期），ConflictResolution：= Excel.XlSaveConflictResolution.xlLocalSessionChanges ActiveWorkbook.Close

'在这里我想保存文档 “ Cal 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

日期范围搜索+将行复制到新工作表（如果有效）

1 个答案: