根据定义日期范围的 2 个输入框，将一个选项卡中 table 中的所有数据复制到同一工作簿中的另一个选项卡中
Copying all data from a table in one tab into another tab in the same workbook based on 2 input boxes which will define a date range
我尝试了很多网站，但我真的很挣扎，因为我似乎无法理解 VBA 代码
tab1 = 来自 C8:Rx 的数据？ ...数据会不断增长，所以 table 会一直变大
tab1 中的 C 列包含日期 21/05/2021
我希望能够有 2 个提示框，我可以在其中输入从 21/05/2021 到 22/05/2021 的日期
当我操作宏时，它只会从这些日期之间的 tab1 中的 table 获取数据
并将它们粘贴到 tab2 中的单元格引用 c8（table 的开头）
Option Explicit
'This subroutine prompts the user to select dates
Public Sub PromptUserForInputDates()
Dim strStart As String, strEnd As String, strPromptMessage As String
'Prompt the user to input the start date
strStart = InputBox("Please enter the start date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Prompt the user to input the end date
strEnd = InputBox("Please enter the end date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Call the next subroutine, which will do produce the output workbook
Call CreateSubsetWorkbook(strStart, strEnd)
End Sub
'This subroutine creates the new workbook based on input from the prompts
Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String)
Dim wbkOutput As Workbook
Dim wksOutput As Worksheet, wks As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long
Dim rngFull As Range, rngResult As Range, rngTarget As Range
'Set references up-front
lngDateCol = 3 '<~ we know dates are in column C
Set wbkOutput = Workbooks.Add
'Loop through each worksheet
For Each wks In ThisWorkbook.Worksheets
With wks
'Create a new worksheet in the output workbook
Set wksOutput = wbkOutput.Sheets.Add
wksOutput.Name = wks.Name
'Create a destination range on the new worksheet that we
'will copy our filtered data to
Set rngTarget = wksOutput.Cells(1, 1)
'Identify the data range on this sheet for the autofilter step
'by finding the last row and the last column
lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set rngFull = .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol))
'Apply a filter to the full range to get only rows that
'are in between the input dates
With rngFull
.AutoFilter Field:=lngDateCol, _
Criteria1:=">=" & StartDate, _
Criteria2:="<=" & EndDate
'Copy only the visible cells and paste to the
'new worksheet in our output workbook
Set rngResult = rngFull.SpecialCells(xlCellTypeVisible)
rngResult.copy Destination:=rngTarget
End With
'Clear the autofilter safely
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
Next wks
'Let the user know our macro has finished!
MsgBox "Data transferred!"
End Sub
此解决方案的作用：
- 假设您的日期在您工作
Column A 中sheet。
- 可用于替换您拥有的
CreateSubsetWorkbook 子。
您仍然可以使用 PromptUserForInputDates 然后调用此 sub 而不是 CreateSubsetWorkbook。
Public Sub FillOutputRange(ByVal StartDate As Date, ByVal EndDate As Date)
Dim SourceSheet As Worksheet
Dim DestinationSheet As Worksheet
Dim TargetCell As Range
Dim LastRow As Long
Dim StartRow As Long
Dim EndRow As Long
Dim RowLoopCounter As Long
Dim EndColumn As Long
Dim OutputDataArray As Variant
With ThisWorkbook
Set SourceSheet = .Sheets("Sheet1") 'Change this to the name of your source sheet
Set DestinationSheet = .Sheets("Sheet2") 'Change this to the name of your destination sheet
End With
With SourceSheet
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each TargetCell In .Range("A1:A" & LastRow)
If TargetCell.Value = StartDate Then
StartRow = TargetCell.Row
Exit For
End If
Next TargetCell
If StartRow = 0 Then MsgBox "Start Date was not found", vbOKOnly, "No Start Date": Exit Sub
For RowLoopCounter = LastRow To StartRow Step -1
If .Range("C" & RowLoopCounter).Value = EndDate Then
EndRow = RowLoopCounter
Exit For
End If
Next RowLoopCounter
If EndRow = 0 Then MsgBox "End Date was not found", vbOKOnly, "No End Date": Exit Sub
EndColumn = .Cells(EndRow, .Columns.Count).End(xlToLeft).Column
OutputDataArray = .Range(.Cells(StartRow, "A"), .Cells(EndRow, EndColumn)).Value
End With
With DestinationSheet
.Range("C8").Resize(UBound(OutputDataArray, 1), UBound(OutputDataArray, 2)).Value = OutputDataArray
End With
End Sub
它是如何工作的？
本子的流程可以描述为：
- 首先，我们设置变量以用作我们
SourceSheet 和 DestinationSheet 的引用 - 确保将这些变量更改为工作簿的正确工作sheet 名称.
- 然后
SourceSheet 我们找到 LastRow -
- 然后我们使用 For Each Next Statement 遍历
Range("A1:A" & LastRow") 中的每个单元格 - 如果说 LastRow，10 那么这将等同于 Range("A1:A10")
- 在循环的每次迭代中，我们都在检查单元格的值是否与我们从
PromptUserForInputDates Sub. 传递的 StartDate 参数相匹配
- 一旦我们有了第一个匹配项，我们就将该单元格的
Row 分配给 StartRow 变量，然后退出循环，代码继续。
- 下一个循环是 For Next Statement，它的语法略有不同。我用它来演示如何使用不同的语句。我们从范围的末尾向后循环，回到
StartRow 这样 EndRow 将从你范围内最后一次出现的 EndDate 建立。
- 既然我们有了
StartRow 和 EndRow，我们就知道目标数据在哪些行之间（含）。
EndColumn 是根据 EndRow 中数据的最后一列找到的 - 你可以根据任何行找到它，我只是选择在最后一行找到它。- 使用 3 个变量，
StartRow、EndRow 和 EndColumn，我们可以通过将目标范围的值分配给数组变量来构建我们的 OutputDataArray。这会自动构建一个包含所有数据的二维数组。
- 最后，使用我们的
DestinationSheet，我们现在将数组写入 sheet 中的一个范围。根据您的问题，我已将其硬编码为从 Range("C8") 开始。
Range.Resize Property 用于更改范围大小以匹配数组大小，这样数组中的数据将直接写入 sheet.
This Chip Pearson article 非常适合学习数组。
注意： 我在每个循环后添加了 If...Then 语句来捕获如果变量 StartRow and/or EndRow 未分配（意味着它们保留其默认值 0）。这通过向用户抛出一个消息框来告知未找到任何日期来处理错误。
演示
基于以下使用的日期：
StartDate = 3/6/2021
EndDate = 6/6/2021
示例源数据：
运行 子的结果：
Option Explicit
'This subroutine prompts the user to select dates
Public Sub PromptUserForInputDates()
Dim strStart As String, strEnd As String, strPromptMessage As String
'Prompt the user to input the start date
strStart = InputBox("Please enter the start date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Prompt the user to input the end date
strEnd = InputBox("Please enter the end date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Call the next subroutine, which will do produce the output workbook
Call FillOutputRange(strStart, strEnd)
End Sub
Public Sub FillOutputRange(ByVal StartDate As Date, ByVal EndDate As Date)
Dim SourceSheet As Worksheet
Dim DestinationSheet As Worksheet
Dim TargetCell As Range
Dim LastRow As Long
Dim StartRow As Long
Dim EndRow As Long
Dim RowLoopCounter As Long
Dim EndColumn As Long
Dim OutputDataArray As Variant
With ThisWorkbook
Set SourceSheet = .Sheets("Branches consolidated Master (4") 'Change this to the name of your source sheet
Set DestinationSheet = .Sheets("Date Extract (5)") 'Change this to the name of your destination sheet
End With
With SourceSheet
LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
For Each TargetCell In .Range("C8:C" & LastRow)
If TargetCell.Value = StartDate Then
StartRow = TargetCell.Row
Exit For
End If
Next TargetCell
For RowLoopCounter = LastRow To StartRow Step -1
If Range("C" & RowLoopCounter).Value = EndDate Then
EndRow = RowLoopCounter
Exit For
End If
Next RowLoopCounter
EndColumn = .Cells(EndRow, .Columns.Count).End(xlToLeft).Column
OutputDataArray = .Range(.Cells(StartRow, "A"), .Cells(EndRow, EndColumn)).Value
End With
With DestinationSheet
.Range("C8").Resize(UBound(OutputDataArray, 1), UBound(OutputDataArray, 2)).Value = OutputDataArray
End With
End Sub
my code error
错误说应用程序定义或对象定义错误
抱歉给您带来了麻烦@samuel
我尝试了很多网站，但我真的很挣扎，因为我似乎无法理解 VBA 代码
tab1 = 来自 C8:Rx 的数据？ ...数据会不断增长，所以 table 会一直变大
tab1 中的 C 列包含日期 21/05/2021
我希望能够有 2 个提示框，我可以在其中输入从 21/05/2021 到 22/05/2021 的日期
当我操作宏时，它只会从这些日期之间的 tab1 中的 table 获取数据
并将它们粘贴到 tab2 中的单元格引用 c8（table 的开头）
Option Explicit
'This subroutine prompts the user to select dates
Public Sub PromptUserForInputDates()
Dim strStart As String, strEnd As String, strPromptMessage As String
'Prompt the user to input the start date
strStart = InputBox("Please enter the start date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Prompt the user to input the end date
strEnd = InputBox("Please enter the end date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Call the next subroutine, which will do produce the output workbook
Call CreateSubsetWorkbook(strStart, strEnd)
End Sub
'This subroutine creates the new workbook based on input from the prompts
Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String)
Dim wbkOutput As Workbook
Dim wksOutput As Worksheet, wks As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long
Dim rngFull As Range, rngResult As Range, rngTarget As Range
'Set references up-front
lngDateCol = 3 '<~ we know dates are in column C
Set wbkOutput = Workbooks.Add
'Loop through each worksheet
For Each wks In ThisWorkbook.Worksheets
With wks
'Create a new worksheet in the output workbook
Set wksOutput = wbkOutput.Sheets.Add
wksOutput.Name = wks.Name
'Create a destination range on the new worksheet that we
'will copy our filtered data to
Set rngTarget = wksOutput.Cells(1, 1)
'Identify the data range on this sheet for the autofilter step
'by finding the last row and the last column
lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set rngFull = .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol))
'Apply a filter to the full range to get only rows that
'are in between the input dates
With rngFull
.AutoFilter Field:=lngDateCol, _
Criteria1:=">=" & StartDate, _
Criteria2:="<=" & EndDate
'Copy only the visible cells and paste to the
'new worksheet in our output workbook
Set rngResult = rngFull.SpecialCells(xlCellTypeVisible)
rngResult.copy Destination:=rngTarget
End With
'Clear the autofilter safely
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
Next wks
'Let the user know our macro has finished!
MsgBox "Data transferred!"
End Sub
此解决方案的作用：
- 假设您的日期在您工作
Column A中sheet。 - 可用于替换您拥有的
CreateSubsetWorkbook子。
您仍然可以使用 PromptUserForInputDates 然后调用此 sub 而不是 CreateSubsetWorkbook。
Public Sub FillOutputRange(ByVal StartDate As Date, ByVal EndDate As Date)
Dim SourceSheet As Worksheet
Dim DestinationSheet As Worksheet
Dim TargetCell As Range
Dim LastRow As Long
Dim StartRow As Long
Dim EndRow As Long
Dim RowLoopCounter As Long
Dim EndColumn As Long
Dim OutputDataArray As Variant
With ThisWorkbook
Set SourceSheet = .Sheets("Sheet1") 'Change this to the name of your source sheet
Set DestinationSheet = .Sheets("Sheet2") 'Change this to the name of your destination sheet
End With
With SourceSheet
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each TargetCell In .Range("A1:A" & LastRow)
If TargetCell.Value = StartDate Then
StartRow = TargetCell.Row
Exit For
End If
Next TargetCell
If StartRow = 0 Then MsgBox "Start Date was not found", vbOKOnly, "No Start Date": Exit Sub
For RowLoopCounter = LastRow To StartRow Step -1
If .Range("C" & RowLoopCounter).Value = EndDate Then
EndRow = RowLoopCounter
Exit For
End If
Next RowLoopCounter
If EndRow = 0 Then MsgBox "End Date was not found", vbOKOnly, "No End Date": Exit Sub
EndColumn = .Cells(EndRow, .Columns.Count).End(xlToLeft).Column
OutputDataArray = .Range(.Cells(StartRow, "A"), .Cells(EndRow, EndColumn)).Value
End With
With DestinationSheet
.Range("C8").Resize(UBound(OutputDataArray, 1), UBound(OutputDataArray, 2)).Value = OutputDataArray
End With
End Sub
它是如何工作的？
本子的流程可以描述为：
- 首先，我们设置变量以用作我们
SourceSheet和DestinationSheet的引用 - 确保将这些变量更改为工作簿的正确工作sheet 名称. - 然后
SourceSheet我们找到LastRow- - 然后我们使用 For Each Next Statement 遍历
Range("A1:A" & LastRow")中的每个单元格 - 如果说LastRow，10那么这将等同于Range("A1:A10") - 在循环的每次迭代中，我们都在检查单元格的值是否与我们从
PromptUserForInputDatesSub. 传递的 - 一旦我们有了第一个匹配项，我们就将该单元格的
Row分配给StartRow变量，然后退出循环，代码继续。 - 下一个循环是 For Next Statement，它的语法略有不同。我用它来演示如何使用不同的语句。我们从范围的末尾向后循环，回到
StartRow这样EndRow将从你范围内最后一次出现的EndDate建立。 - 既然我们有了
StartRow和EndRow，我们就知道目标数据在哪些行之间（含）。 EndColumn是根据EndRow中数据的最后一列找到的 - 你可以根据任何行找到它，我只是选择在最后一行找到它。- 使用 3 个变量，
StartRow、EndRow和EndColumn，我们可以通过将目标范围的值分配给数组变量来构建我们的OutputDataArray。这会自动构建一个包含所有数据的二维数组。 - 最后，使用我们的
DestinationSheet，我们现在将数组写入 sheet 中的一个范围。根据您的问题，我已将其硬编码为从Range("C8")开始。 Range.Resize Property 用于更改范围大小以匹配数组大小，这样数组中的数据将直接写入 sheet.
StartDate 参数相匹配
This Chip Pearson article 非常适合学习数组。
注意： 我在每个循环后添加了 If...Then 语句来捕获如果变量 StartRow and/or EndRow 未分配（意味着它们保留其默认值 0）。这通过向用户抛出一个消息框来告知未找到任何日期来处理错误。
演示
基于以下使用的日期：
StartDate = 3/6/2021
EndDate = 6/6/2021
示例源数据：
运行 子的结果：
Option Explicit
'This subroutine prompts the user to select dates
Public Sub PromptUserForInputDates()
Dim strStart As String, strEnd As String, strPromptMessage As String
'Prompt the user to input the start date
strStart = InputBox("Please enter the start date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Prompt the user to input the end date
strEnd = InputBox("Please enter the end date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Call the next subroutine, which will do produce the output workbook
Call FillOutputRange(strStart, strEnd)
End Sub
Public Sub FillOutputRange(ByVal StartDate As Date, ByVal EndDate As Date)
Dim SourceSheet As Worksheet
Dim DestinationSheet As Worksheet
Dim TargetCell As Range
Dim LastRow As Long
Dim StartRow As Long
Dim EndRow As Long
Dim RowLoopCounter As Long
Dim EndColumn As Long
Dim OutputDataArray As Variant
With ThisWorkbook
Set SourceSheet = .Sheets("Branches consolidated Master (4") 'Change this to the name of your source sheet
Set DestinationSheet = .Sheets("Date Extract (5)") 'Change this to the name of your destination sheet
End With
With SourceSheet
LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
For Each TargetCell In .Range("C8:C" & LastRow)
If TargetCell.Value = StartDate Then
StartRow = TargetCell.Row
Exit For
End If
Next TargetCell
For RowLoopCounter = LastRow To StartRow Step -1
If Range("C" & RowLoopCounter).Value = EndDate Then
EndRow = RowLoopCounter
Exit For
End If
Next RowLoopCounter
EndColumn = .Cells(EndRow, .Columns.Count).End(xlToLeft).Column
OutputDataArray = .Range(.Cells(StartRow, "A"), .Cells(EndRow, EndColumn)).Value
End With
With DestinationSheet
.Range("C8").Resize(UBound(OutputDataArray, 1), UBound(OutputDataArray, 2)).Value = OutputDataArray
End With
End Sub
my code error
错误说应用程序定义或对象定义错误
抱歉给您带来了麻烦@samuel