我编写了一个宏来格式化大约20个.csv文件，其中b列中的测量日期时间（即21/01/2015 03:15）和c栏中的相应数据。然后，它会将所有.csv文件中的数据复制到新工作表Workbooks("CSV fix RPS data_v6.xlsm").Sheets("a")
每个.csv的开始/结束时间都不一样。我想修改代码，以便查看所有日期列中的最新开始时间/最早完成时间，并从所有数据中复制此时间段内的数据并将其粘贴到新工作表中。
到目前为止，我的代码如下，但我对如何开始比较日期时间感到困惑。
Sub Get_raw_data_RPSCSV_30_03_15()
Dim row As Integer
Dim row_1 As Integer
Dim col As Integer
Dim col_2 As Integer
Dim col_3 As Integer
Dim time_last As Date
Dim EndRow As Long
Dim date_start As Date
Dim time_start As Date
Dim DateTime As Date
Dim FinalRow As Long
Dim Logg, Path, Filename, sheetname As String
Dim copyrange As Excel.Range
With Workbooks("CSV fix RPS data_v6.xlsm").Worksheets("home") 'take the
FinalRow = .Cells(Rows.count, 1).End(xlUp).row
For i = 3 To FinalRow '' keep this to reference the files
Logg = .Cells(i, 4).Value 'logger name row "f:f"
Path = .Cells(i, 2).Value '"b:b"
Filename = .Cells(i, 3).Value '"c:c"
Application.DisplayAlerts = False
Workbooks.Open Filename:=Path & Filename, Local:=True
With Workbooks(Filename).Sheets(Logg)
date_start = .Range("b17").Value ' merge date and time and fill down the row
time_start = .Range("c17").Value
Range("b18").Value = date_start + time_start
EndRow = .Range("a" & .Rows.count).End(xlUp).row
row = 18
For row = 18 To EndRow - 1 '(minus 1 to stop it filling in an extra time value at the end)
col = 2
row_1 = row + 1
time_last = .Cells(row, col).Value
.Cells(row_1, col).Formula = DateAdd("n", 15, time_last)
Next row
.Range("c18:c" & EndRow).NumberFormat = "General" ' remove any weird number formatting
.Range("c18:c" & EndRow).Value = .Range("a18:a" & EndRow).Value
'Set copyrange = .Range("b18:c" & EndRow)
Set copyrange = .Range("b18:c" & EndRow) 'location of datetime and data
Dim lRowCount As Long
lRowCount = copyrange.Rows.count
Dim lColumnCount As Long
lColumnCount = copyrange.Columns.count
Dim copyvalue As Variant
copyvalue = copyrange.Value
End With
With Workbooks("CSV fix RPS data_v6.xlsm").Sheets("a") ' sheet to copy the data into
.Cells(1, i * 3 - 7).Value = Logg
.Cells(2, i * 3 - 8).Resize(lRowCount, lColumnCount).Value = copyvalue 'to paste the range of values rather than the first value only
End With
copyvalue = Empty 'releases memory
Next i
Application.DisplayAlerts = True
End With
''call a sub to compare date/time here''
End Sub
''''2015年4月14日更新
我写了一些代码来定义下面的MaxStartDate和MinEndDate，但我不确定如何使用此代码然后仅选择这些日期之间范围的日期/数据。
Sub align_datetime()
Dim MaxStartDate As Date
Dim MinEndDate As Date
Dim LastCol As Long
Dim date_i As Integer
Dim DateMax As Date
Dim LastRow_date As Long
Dim LastRow_date_new As Long
With Worksheets("a")
LastCol = Sheets("a").Cells(1, Columns.count).End(xlToLeft).Column
'' Go along the columns and find the latest date
DateMax = Cells(2, 1).Value
LastRow_date = .Range("a" & .Rows.count).End(xlUp).row
Date_end = Cells(LastRow_date, 1).Value
For date_i = 4 To LastCol Step 3
If Cells(2, date_i).Value > DateMax Then
DateMax = Cells(2, date_i).Value
End If
LastRow_date_new = Application.CountA(Range((Cells(1, date_i)), (Cells(65536, date_i))))
Date_end = Cells(LastRow_date_new, date_i).Value
If Cells(LastRow_date_new, date_i).Value < Date_end Then
Date_end = Cells(LastRow_date_new, date_i).Value
End If
Next date_i
End With
End Sub
答案 0 :(得分：1)
你可以按照FreeMan的建议使用DIM两个变量。
Dim MaxStart as date, MInEnd as date
在循环中指定如下值：
maxstart = Max(MaxStart, NextDate)
minStart = Min(MinStart, NextDate)
或者，您可以使用DateDiff函数来确定nextdate是否大于或小于maxstart和minstart中已有的。
if datediff("D", maxstart, nextdate) > 0 then
maxstart = nextdate
endif
if datediff("D", minstart, nextdate) < 0 then
minstart = nextdate
endif
DateDiff还支持时差，如果您想要更精确而不是几天，或者如果您只想比较时间是日期的一部分时的天差。
答案 1 :(得分：0)
这是我提出的解决方案。我很确定它可以更加精致，但目前它正在完成这项工作。
Sub align_datetime()
Dim MaxStartDate As Date
Dim MinEndDate As Date
Dim LastCol As Long
Dim date_i As Integer
Dim DateMax As Date
Dim LastRow_date As Long
Dim LastRow_date_new As Long
With Worksheets("a")
LastCol = Sheets("a").Cells(1, Columns.count).End(xlToLeft).Column
'' Go along the columns and find the latest date
DateMax = Sheets("a").Cells(2, 1).Value
LastRow_date = Sheets("a").Range("a" & .Rows.count).End(xlUp).row
Date_end = Sheets("a").Cells(LastRow_date, 1).Value
For date_i = 4 To LastCol Step 3
If Sheets("a").Cells(2, date_i).Value > DateMax Then
DateMax = Sheets("a").Cells(2, date_i).Value
End If
LastRow_date_new = Application.CountA(Sheets("a").Range((.Cells(1, date_i)), (.Cells(65536, date_i))))
Date_end = Sheets("a").Cells(LastRow_date_new, date_i).Value
If Sheets("a").Cells(LastRow_date_new, date_i).Value < Date_end Then
Date_end = Sheets("a").Cells(LastRow_date_new, date_i).Value
End If
Next date_i
Dim SearchCol As Integer
Dim row_i As Integer
Dim row_j As Integer
For SearchCol = 1 To LastCol Step 3
LastRow_date_new = Application.CountA(.Range((.Cells(1, SearchCol)), (.Cells(65536, SearchCol))))
For row_i = 2 To LastRow_date_new
If Sheets("a").Cells(row_i, SearchCol).Value = DateMax Then Start_row = row_i
Next row_i
For row_j = LastRow_date_new To 2 Step -1
If Sheets("a").Cells(row_j, SearchCol).Value = Date_end Then End_row = row_j
Next row_j
''''''' use range col1, row i to col2, row j to copy into new sheet
Dim startrange As Range
Dim endrange As Range
Dim startval As Range
Dim endval As Range
Dim dataCol As Integer
Set startval = Sheets("a").Cells(Start_row, SearchCol)
dataCol = SearchCol + 1
Set endval = Sheets("a").Cells(End_row, dataCol)
Dim DataRange As Range
Dim dataRowCount As Long
Dim dataColCount As Long
Dim DataVal As Variant
Set DataRange = Sheets("a").Range(startval.Address, endval.Address)'select range between the start and end dates
dataRowCount = DataRange.Rows.count 'to make sure the range you copy the data to is the same size as the range of data you copy
dataColCount = DataRange.Columns.count
DataVal = DataRange.Value
With Workbooks("CSV fix RPS data_v7.xlsm").Sheets("b") ' sheet to copy the data into
.Cells(2, SearchCol).Resize(dataRowCount, dataColCount).Value = DataVal 'to paste the range of values rather than the first value only
Sheets("b").Cells(1, SearchCol + 1).Value = Sheets("a").Cells(1, SearchCol + 1).Value
End With
DataVal = Empty 'releases memory
Next SearchCol
End With
End Sub