複製inputbox指示的多個範圍

Question

到目前爲止，我有一個宏來查找一年，並將其複製到新工作表。不過，我可能要多年。我的數據集的結構如下：

Col A Col B Col C Col D ColE 
Year Week Amount time forecast 
2000 1  368  2000w1 400 
2000 2  8646 2000w2 8500 
until... 
2014 52  46546 2014w52 47000 

到現在爲止，我的宏：下面

Sub Copyyear() 
Dim Forecastyear As String 
Dim Rng As Range 
Dim cell As Range 

Forecastyear = InputBox("Enter a year to forecast") 

If Trim(Forecastyear) <> "" Then 
    With Sheets(2) 
     For Each cell In .Range("A:A") 
      If cell.Value = Forecastyear Then 'find first occurrence of year 
       Set Rng = cell 
       Exit For 
      End If 
     Next 
     '.Range(Rng.Address).Resize(52, 5).Select 'resize for 52 rows and 5 columns 
     Rng.Resize(52, 5).Copy Destination:=Sheets("Moving Average").Range("A2") 
    End With 
End If 

' Record in new sheet 
Worksheets("Moving Average").Select 
    Range("A1").Value = "YEAR" 
    Range("B1").Value = "WEEK" 
    Range("C1").Value = "AMOUNT" 
    Range("D1").Value = "TIME" 
    Range("E1").Value = "FORECAST" 

' next macro 
    AddForecastPerformance 

End Sub 

Answer 1

使用。年進入像2001,2002,2003,2004等

Sub Copyyear() 
Dim Forecastyear As String 
Dim Rng As Range 
Dim cell As Range 

Forecastyear = InputBox("Enter year(s) to forecast, for multiple year input as 2001,2002,2003 etc") 

If InStr(1, Forecastyear, ",") > 0 Then 
    sp = Split(Forecastyear, ",") 
    For i = 0 To UBound(sp) 
     If Trim(sp(i)) <> "" Then 
      With Sheets(2) 
       For Each cell In .Range("A:A") 
        If cell.Value = CInt(sp(i)) Then 'find first occurrence of year 
         Set Rng = cell 
         Exit For 
        End If 
       Next 
       '.Range(Rng.Address).Resize(52, 5).Select 'resize for 52 rows and 5 columns 
       Rng.Resize(52, 5).Copy Destination:=Sheets("Moving Average").Range("A2").Offset(0 + (52 * i), 0) 
      End With 
     End If 
    Next 
Else 
    If Trim(Forecastyear) <> "" Then 
     With Sheets(2) 
      For Each cell In .Range("A:A") 
       If cell.Value = Forecastyear Then 'find first occurrence of year 
        Set Rng = cell 
        Exit For 
       End If 
      Next 
      '.Range(Rng.Address).Resize(52, 5).Select 'resize for 52 rows and 5 columns 
      Rng.Resize(52, 5).Copy Destination:=Sheets("Moving Average").Range("A2") 
     End With 
    End If 
End If 

' Record in new sheet 
with Worksheets("Moving Average") 
    .Range("A1").Value = "YEAR" 
    .Range("B1").Value = "WEEK" 
    .Range("C1").Value = "AMOUNT" 
    .Range("D1").Value = "TIME" 
    .Range("E1").Value = "FORECAST" 
end with 

' next macro 
    AddForecastPerformance 

End Sub