Дата и время начала сопоставления в формате Excel.

Question

Я написал макрос для форматирования около 20 CSV-файлов с datetime измерения в столбце 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 

«» «» Update 14/04/15

я написал немного кода, чтобы определить 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 

Answer 1

Вот решение, с которым я столкнулся. Я уверен, что он может быть намного более утонченным, но на данный момент он выполняет свою работу.

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 

Answer 2

Вы можете использовать DIM две переменные, как предложено FreeMan.

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 поддерживает различия во времени и если вы хотите более высокую точность, чем всего за несколько дней, или если вы хотите, чтобы сравнить разницу дней, когда времена являются частью даты.