如果输入的句点超过EXCEL-VBA中的特定句点，如何复制最后一个特定数目的值

Question

我创建了一个代码来从；所选文件"；工作表转换为已创建的名为"；数据"；。该代码允许用户在名为"B2"的单独工作表中输入国家名称("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和amp；filename=time_series_covid19_confirmed_global.csv在第一张纸上输入"；选择文件；附加的图像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

结束子

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