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

我要通过网络查询从SharePoint中提取数据列表到Excel中的空白工作表中，然后将特定月份的行复制到特定工作表中(例如，所有7月数据从SharePoint工作表复制到7月工作表，从SharePoint工作表到6月工作表的所有6月数据等)。

样本数据

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

这不是一次性的练习。我正在尝试建立一个仪表板，使我的老板可以从SharePoint中获取最新数据并查看每月结果，因此它需要能够始终执行并进行整洁的组织。

解决方案

回答

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

回答

这是部分伪代码，但我们将需要类似以下内容的代码：

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

回答

它的工作原理是：它的设置方式是从即时窗格中调用的，但是我们可以轻松创建一个sub()，它每个月都会调用一次MoveData，然后只需调用该子即可。

复制完所有数据后，我们可能需要添加逻辑以对每月数据进行排序

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

回答

这是另一种使用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

回答

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

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

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

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

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