excel 将下三个月的值从当前月份复制到另一个工作表VBA

axkjgtzd 于 2023-06-30 发布在其他

关注(0)|答案(1)|浏览(168)

我有2023年1月至12月的样本数据。从当前月份（七月）开始，我想将下三个月的值复制到新工作簿。
例如，对于当前月份6月，它将需要下三个月。如果是七月，那就是八月，九月，十月
销售工作簿-->新工作簿。
销售工作簿. xlsx

Month           Value       Desc
01-01-2023       300        001
01-02-2023       500        001
01-03-2023       200        001
01-04-2023       400        001
01-05-2023       500        001
01-06-2023       500        001
01-07-2023       700        001
01-08-2023       800        001
01-09-2023       200        001
01-10-2023       100        001
01-11-2023       300        001
01-12-2023       600        001

新建工作簿

01-07-2023       700        001
01-08-2023       800        001
01-09-2023       200        001

Sub CopyNextThreeMonths()
        Dim sourceSheet As Worksheet
        Dim destinationSheet As Worksheet
        Dim currentDate As Date
        Dim nextThreeMonths As Range
        Dim nextMonth As Date
        
        ' Set the source sheet ( "Sales Workbook")
        Set sourceSheet = ThisWorkbook.Sheets("Sales Workbook")
        
        ' Set the destination sheet ("New workbook")
        Set destinationSheet = ThisWorkbook.Sheets("New workbook")
        
        ' Set the current date
        currentDate = Date
        
        ' Set the range for the next three months
        Set nextThreeMonths = destinationSheet.Range("A1:C100") ' Adjust the range as per your requirement
        
        ' Loop through each cell in the range and copy values from the corresponding cells in the source sheet
        For Each cell In nextThreeMonths
            nextMonth = DateAdd("m", 1, currentDate)
            If Month(nextMonth) = Month(cell.Value) And Year(nextMonth) = Year(cell.Value) Then
                cell.Value = sourceSheet.Range(cell.Address).Value
            End If
        Next cell
    End Sub

excel

来源：https://stackoverflow.com/questions/76570406/copy-next-three-month-value-from-current-month-move-to-another-sheet-vba

1条答案

按热度按时间

8ehkhllq1#

请尝试使用下一个代码：

Sub MoveFollowingThreeMonthsData()
  Dim ws As Worksheet, lastR As Long, wbN As Workbook, curD As Date, copyRng As Range, mtch
  
  Set ws = ActiveSheet
  lastR = ws.Range("A" & ws.rows.count).End(xlUp).row
  curD = Date

  mtch = Application.match(CLng(DateSerial(Year(curD), Month(curD), 1)), ws.Range("A2:A" & lastR), True) 'find the row of the current month
  If IsNumeric(mtch) Then 'if a match exists:
    Set copyRng = ws.Range("A" & mtch + 2, "C" & mtch + 4) 'set the range to be copied
    Set wbN = Workbooks.Add(xlWBATWorksheet)                    'create a new workbook, with a single sheet
    copyRng.Copy wbN.Sheets(1).Range("A1")                      'copy the necessary range in the single sheet of the newly created workbook (in A1)
  End If
End Sub

它假设要处理的范围存在于列A：C中，从第一行开始。而且也将有数据后，12月，本年度时，代码将工作的10月-12月月...
如果没有单元格格式复制是必要的，代码可以很容易地适应复制数组的范围。
下一个版本是您的改编代码，使用您使用的工作表：

Sub CopyNextThreeMonths()
        Dim sourceSheet As Worksheet, destinationSheet As Worksheet
        Dim currentDate As Date, curMonth As Date, lastR As Long, copyRng As Range, mtch
        
        ' Set the source sheet ( "Sales Workbook")
        Set sourceSheet = ThisWorkbook.Sheets("Sales Workbook")
        lastR = sourceSheet.Range("A" & sourceSheet.rows.count).End(xlUp).row 'last row on column A:A
        
        ' Set the destination sheet ("New workbook")
        Set destinationSheet = ThisWorkbook.Sheets("New workbook")
        
        ' Set the current date
        currentDate = Date
        
        mtch = Application.match(CLng(DateSerial(Year(currentDate), Month(currentDate), 1)), sourceSheet.Range("A1:A" & lastR), True) 'find the row of the current month
        If IsNumeric(mtch) Then 'if a match exists:
            Set copyRng = sourceSheet.Range("A" & mtch + 1, "C" & mtch + 3) 'set the range to be copied
            copyRng.Copy destinationSheet.Range("A1")                                       'copy the necessary range in destinationSheet (A1)
            destinationSheet.Activate 'activating the destination sheet
        Else
            MsgBox "No any current month has been found..."
        End If
End Sub

赞(0）回复(0）举报 2023-06-30

我来回答

excel 将下三个月的值从当前月份复制到另一个工作表VBA

1条答案

相关问题

热门标签

最新问答