基于名称日期的Excel匹配和将数据复制到另一个工作表

Question

我已经搜索了高低，并测试了许多VB脚本，但还没有找到解决方案。以下是我有Data的数据

需要有一个像result下面的输出

我正在使用的VB代码

Option Explicit 
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

但是当数据如下所示，结果并没有显示两行具有不同的时间时，任何帮助都会非常感激。

Data 3

RGDS

Answer 1

谢谢你分享你的代码。我认为它看起来比你需要的多一点。离开你的例子，如果一切都是这样格式化的，这将是你的解决方案：

Option Explicit
Sub SplitDateTime()

Dim mydate As String, mytime As String, mytime2 As String, i As Long, sht As Worksheet, lastrow As Long

Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

'Change headers
Range("H1:H" & lastrow).Value = Range("G1:G" & lastrow).Value
Range("G1:G" & lastrow).Value = Range("F1:F" & lastrow).Value
Range("D1").Value = "Date"
Range("E1").Value = "C/In"
Range("F1").Value = "C/Out"

'Move values around
For i = 2 To lastrow Step 2

    mydate = DateValue(Range("D" & i).Value)
    mytime = TimeValue(Range("D" & i).Value)
    mytime2 = TimeValue(Range("D" & i + 1).Value)

    Range("D" & i).Value = mydate
    Range("E" & i).Value = mytime
    Range("F" & i).Value = mytime2

Next i

'Delete excess rows
For i = lastrow To 2 Step -2
    Range("A" & i).EntireRow.Delete
Next i

'Regrab lastrow value
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'Change date format
Range("D2:D" & lastrow).NumberFormat = "m/d/yyyy"

End Sub