excel - 如果输入的时间段多于 EXCEL-VBA 中的特定值，如何复制最后一个特定数量的值

Question

我创建了一个代码，将数据从“选定文件”工作表复制到已创建的名为“数据”的工作表中。该代码允许用户在名为“SelectFile”的单独工作表中输入国家名称（“B2”）、开始日期（“B3”）和结束日期（“B4”）。单击按钮...用户允许选择 excel 文件，然后将数据拉入“数据”工作表，仅包括所选国家/地区的这些日期之间的记录（包括开始日期和结束日期）。所以，我需要一个帮助来添加一个命令，如果用户输入的开始日期和结束日期的时间超过 40 天，VBA 只会复制最后 40 天。

所选文件有许多国家，并附在此链接中https://data.humdata.org/hxlproxy/api/data-preview.csv?url=https%3A%2F%2Fraw.githubusercontent.com%2FCSSEGISandData%2FCOVID-19 %2Fmaster%2Fcsse_covid_19_data%2Fcsse_covid_19_time_series%2Ftime_series_covid19_confirmed_global.csv&filename=time_series_covid19_confirmed_global.csv 输入第一张“SelectFile”图像附在https://i.stack.imgur.com/OQhqN.png

我的代码已附上

Sub Get_Data_From_File()
Dim FileToOpen As Variant
Dim OpenBook As Workbook

Dim countryName As Variant
Dim Lastrow As Long
Dim Lastcolumn As Long

Dim mainFile As Workbook
Dim mainsheet As Worksheet
Dim dataSheet As Worksheet
Dim sht As Worksheet
Dim selectedRow As Long

Dim dSDate As Date, dEDate As Date
Dim lRowStart As Long, lRowEnd As Long
Dim aData() As Variant
Dim i As Long
Dim y As Long




Set mainFile = ThisWorkbook

Sheets("SelectFile").Activate
Set mainsheet = ActiveSheet
countryName = Range("B2").Value
dSDate = Range("B3").Value
dEDate = Range("B4").Value

Sheets("Data").Activate
Set dataSheet = ActiveSheet


Range("A2:G1000").Clear


FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls,(*.csv*),*csv*")
If FileToOpen <> False Then
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
    Set sht = ActiveSheet
    
    Lastrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
    Lastcolumn = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
    
    For i = 1 To Lastrow
    
        If Cells(i, 2) = countryName Then
        
            selectedRow = i
            Exit For
        End If
        Next i
    For y = 1 To Lastcolumn
       If Cells(1, y) = dSDate Then
        lRowStart = y
        Debug.Print "Start row = " & lRowStart
        Exit For
    End If
    Next y
    For y = 1 To Lastcolumn
    If Cells(1, y) = dEDate Then
        lRowEnd = y
        Debug.Print "End row = " & lRowEnd
        Exit For
    End If
Next y
    
    
   OpenBook.Sheets(1).Range(Cells(selectedRow, lRowStart), Cells(selectedRow, lRowEnd)).Copy


    
    mainFile.Activate
    dataSheet.Activate
    
    

    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    
    Application.DisplayAlerts = False
    
        OpenBook.Close False
    
    Application.DisplayAlerts = True
    
End If
Application.ScreenUpdating = True

结束子

标签： excelvba

Answer 1

如果期间超出您的需要，请调整开始日期。

If dtEnd - dtStart > 39 Then
    dtStart = dtEnd - 39
ElseIf dtEnd < dtStart Then
    dtEnd = dtStart
End If

尽可能使用明确的工作簿和工作表引用来避免使用激活/选择时出现问题。

Option Explicit

Sub Get_Data_From_File()

    Dim wb As Workbook, wbSource As Workbook
    Dim ws As Worksheet, wsData As Worksheet, wsSource As Worksheet
    Dim rngCopy As Range
    Dim iLastRow As Long, iLastCol As Integer
    Dim iColStart As Integer, iColEnd As Integer, c As Integer, r As Long

    Dim sCountry As String, sFileToOpen
    Dim dtStart As Date, dtEnd As Date

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("SelectFile")
    Set wsData = wb.Sheets("Data")

    With ws
        sCountry = Trim(.Range("B2").Value)
        dtStart = CDate(.Range("B3"))
        dtEnd = CDate(.Range("B4"))
    End With

    ' constrain dates
    If dtEnd - dtStart > 39 Then
        dtStart = dtEnd - 39
    ElseIf dtEnd < dtStart Then
        dtEnd = dtStart
    End If

    ' open data file
    sFileToOpen = Application.GetOpenFilename( _
            Title:="Browse for your File & Import Range", _
            FileFilter:="Excel Files (*.xls*),*xls,(*.csv*),*csv*")
    
    If sFileToOpen = "" Then
        MsgBox "No file chosen", vbCritical
        Exit Sub
    End If

    Set wbSource = Application.Workbooks.Open(sFileToOpen, False, True) 'read only
    Set wsSource = wbSource.Sheets(1)

    With wsSource
        iLastRow = .Cells(Rows.Count, "B").End(xlUp).Row
        iLastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
       
        For c = 1 To iLastCol
            If .Cells(1, c) = dtStart Then
                iColStart = c
                'Debug.Print dtStart, " Col = " & c
            End If
            If .Cells(1, c) = dtEnd Then
                iColEnd = c
                'Debug.Print dtEnd, " Col = " & c
            End If
        Next
    End With

    ' check dates found
    If iColStart = 0 Or iColEnd = 0 Then
        MsgBox "Date not found '" & dtStart & "' or '" & dtEnd & "'", vbCritical
        Exit Sub
    End If
    
    'search for country
    With wsSource
        For r = 1 To iLastRow
            If LCase(Trim(Cells(r, 2))) = LCase(sCountry) Then
                Set rngCopy = wsSource.Range(.Cells(r, iColStart), .Cells(r, iColEnd))
                Exit For
            End If
        Next
    End With

    ' country not found
    If rngCopy Is Nothing Then
        MsgBox "Country not found '" & sCountry & "'", vbCritical
        Exit Sub
    End If

    ' transpose data into row
    wsData.Range("A2:G1000").Clear
    rngCopy.Copy
    wsData.Range("C2").PasteSpecial Paste:=xlPasteAll, _
           Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Application.CutCopyMode = False
    wsData.Activate
    wsData.Range("C2").Select

    MsgBox rngCopy.Columns.Count & " values copied from " & rngCopy.Address & vbCrLf & _
        "For " & dtStart & " to " & dtEnd, vbInformation
    wbSource.Close False

End Sub