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 

を使用していますが、データが結果以下のようなものであるときに、2つを示してdoesntのような出力を持っている必要があります持っているデータであり、行が異なると、どんな助けでも大歓迎です。あなたのコードを共有するための

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