vba 是否有宏有条件地将行复制到另一个工作表？

Is there a macro to conditionally copy rows to another worksheet?

提问by theo

Is there a macro or a way to conditionally copy rows from one worksheet to another in Excel 2003?

在 Excel 2003 中，是否有宏或有条件地将行从一个工作表复制到另一个工作表的方法？

I'm pulling a list of data from SharePoint via a web query into a blank worksheet in Excel, and then I want to copy the rows for a particular month to a particular worksheet (for example, all July data from a SharePoint worksheet to the Jul worksheet, all June data from a SharePoint worksheet to Jun worksheet, etc.).

我正在通过 Web 查询将 SharePoint 中的数据列表提取到 Excel 中的空白工作表中，然后我想将特定月份的行复制到特定工作表（例如，SharePoint 工作表中的所有 7 月数据到Jul 工作表，从 SharePoint 工作表到 Jun 工作表的所有六月数据等）。

Sample data

样本数据

Date - Project - ID - Engineer
8/2/08 - XYZ - T0908-5555 - JS
9/4/08 - ABC - T0908-6666 - DF
9/5/08 - ZZZ - T0908-7777 - TS

It's not a one-off exercise. I'm trying to put together a dashboard that my boss can pull the latest data from SharePoint and see the monthly results, so it needs to be able to do it all the time and organize it cleanly.

这不是一次性的练习。我正在尝试组合一个仪表板，让我的老板可以从 SharePoint 中提取最新数据并查看月度结果，因此它需要能够始终执行此操作并将其组织得井井有条。

回答by theo

This works: The way it's set up I called it from the immediate pane, but you can easily create a sub() that will call MoveData once for each month, then just invoke the sub.

这是有效的：它的设置方式我从直接窗格中调用它，但是您可以轻松创建一个 sub() 将每个月调用一次 MoveData，然后调用 sub。

You may want to add logic to sort your monthly data after it's all been copied

您可能想要添加逻辑来在全部复制后对您的每月数据进行排序

Public Sub MoveData(MonthNumber As Integer, SheetName As String)

Dim sharePoint As Worksheet
Dim Month As Worksheet
Dim spRange As Range
Dim cell As Range

Set sharePoint = Sheets("Sharepoint")
Set Month = Sheets(SheetName)
Set spRange = sharePoint.Range("A2")
Set spRange = sharePoint.Range("A2:" & spRange.End(xlDown).Address)
For Each cell In spRange
    If Format(cell.Value, "MM") = MonthNumber Then
        copyRowTo sharePoint.Range(cell.Row & ":" & cell.Row), Month
    End If
Next cell

End Sub

Sub copyRowTo(rng As Range, ws As Worksheet)
    Dim newRange As Range
    Set newRange = ws.Range("A1")
    If newRange.Offset(1).Value <> "" Then
        Set newRange = newRange.End(xlDown).Offset(1)
        Else
        Set newRange = newRange.Offset(1)
    End If
    rng.Copy
    newRange.PasteSpecial (xlPasteAll)
End Sub

回答by Jon Fournier

Here's another solution that uses some of VBA's built in date functions and stores all the date data in an array for comparison, which may give better performance if you get a lot of data:

这是另一种解决方案，它使用一些 VBA 的内置日期函数并将所有日期数据存储在一个数组中进行比较，如果您获得大量数据，这可能会提供更好的性能：

Public Sub MoveData(MonthNum As Integer, FromSheet As Worksheet, ToSheet As Worksheet)
    Const DateCol = "A" 'column where dates are store
    Const DestCol = "A" 'destination column where dates are stored. We use this column to find the last populated row in ToSheet
    Const FirstRow = 2 'first row where date data is stored
    'Copy range of values to Dates array
    Dates = FromSheet.Range(DateCol & CStr(FirstRow) & ":" & DateCol & CStr(FromSheet.Range(DateCol & CStr(FromSheet.Rows.Count)).End(xlUp).Row)).Value
    Dim i As Integer
    For i = LBound(Dates) To UBound(Dates)
        If IsDate(Dates(i, 1)) Then
            If Month(CDate(Dates(i, 1))) = MonthNum Then
                Dim CurrRow As Long
                'get the current row number in the worksheet
                CurrRow = FirstRow + i - 1
                Dim DestRow As Long
                'get the destination row
                DestRow = ToSheet.Range(DestCol & CStr(ToSheet.Rows.Count)).End(xlUp).Row + 1
                'copy row CurrRow in FromSheet to row DestRow in ToSheet
                FromSheet.Range(CStr(CurrRow) & ":" & CStr(CurrRow)).Copy ToSheet.Range(DestCol & CStr(DestRow))
            End If
        End If
    Next i
End Sub

回答by Robert Mearns

The way I would do this manually is:

我手动执行此操作的方式是：

• Use Data - AutoFilter
• Apply a custom filter based on a date range
• Copy the filtered data to the relevant month sheet
• Repeat for every month

• 使用数据 - 自动过滤
• 根据日期范围应用自定义过滤器
• 将过滤后的数据复制到相关月份表
• 每个月重复一次

Listed below is code to do this process via VBA.

下面列出的是通过 VBA 执行此过程的代码。

It has the advantage of handling monthly sections of data rather than individual rows. Which can result in quicker processing for larger sets of data.

它具有处理每月数据部分而不是单个行的优点。这可以更快地处理更大的数据集。

    Sub SeperateData()

    Dim vMonthText As Variant
    Dim ExcelLastCell As Range
    Dim intMonth As Integer

   vMonthText = Array("January", "February", "March", "April", "May", _
 "June", "July", "August", "September", "October", "November", "December")

        ThisWorkbook.Worksheets("Sharepoint").Select
        Range("A1").Select

    RowCount = ThisWorkbook.Worksheets("Sharepoint").UsedRange.Rows.Count
'Forces excel to determine the last cell, Usually only done on save
    Set ExcelLastCell = ThisWorkbook.Worksheets("Sharepoint"). _
     Cells.SpecialCells(xlLastCell)
'Determines the last cell with data in it


        Selection.EntireColumn.Insert
        Range("A1").FormulaR1C1 = "Month No."
        Range("A2").FormulaR1C1 = "=MONTH(RC[1])"
        Range("A2").Select
        Selection.Copy
        Range("A3:A" & ExcelLastCell.Row).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Calculate
    'Insert a helper column to determine the month number for the date

        For intMonth = 1 To 12
            Range("A1").CurrentRegion.Select
            Selection.AutoFilter Field:=1, Criteria1:="" & intMonth
            Selection.Copy
            ThisWorkbook.Worksheets("" & vMonthText(intMonth - 1)).Select
            Range("A1").Select
            ActiveSheet.Paste
            Columns("A:A").Delete Shift:=xlToLeft
            Cells.Select
            Cells.EntireColumn.AutoFit
            Range("A1").Select
            ThisWorkbook.Worksheets("Sharepoint").Select
            Range("A1").Select
            Application.CutCopyMode = False
        Next intMonth
    'Filter the data to a particular month
    'Convert the month number to text
    'Copy the filtered data to the month sheet
    'Delete the helper column
    'Repeat for each month

        Selection.AutoFilter
        Columns("A:A").Delete Shift:=xlToLeft
 'Get rid of the auto-filter and delete the helper column

    End Sub

回答by BKimmel

This is partially pseudocode, but you will want something like:

这是部分伪代码，但您将需要以下内容：

rows = ActiveSheet.UsedRange.Rows
n = 0

while n <= rows
  if ActiveSheet.Rows(n).Cells(DateColumnOrdinal).Value > '8/1/08' AND < '8/30/08' then
     ActiveSheet.Rows(n).CopyTo(DestinationSheet)
  endif
  n = n + 1
wend

回答by RickL

If this is just a one-off exercise, as an easier alternative, you could apply filters to your source data, and then copy and paste the filtered rows into your new worksheet?

如果这只是一次性练习，作为更简单的替代方法，您可以将过滤器应用于源数据，然后将过滤后的行复制并粘贴到新工作表中？