在 Excel 2003 中是否有宏或方法可以有条件地将行从一个工作表复制到另一个工作表？
我通过 Web 查询将 SharePoint 中的数据列表提取到 Excel 中的空白工作表中，然后我想将特定月份的行复制到特定工作表（例如，来自 SharePoint 的所有 7 月数据）工作表到 Jul 工作表，从 SharePoint 工作表到 Jun 工作表的所有 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 中提取最新数据并查看每月结果，因此它需要能够一直这样做并干净利落地组织它。
【问题讨论】：
标签： excel copy excel-2003 worksheet vba
这行得通：它的设置方式我从直接窗格中调用它，但您可以轻松创建一个 sub()，每个月调用一次 MoveData，然后调用 sub。
您可能需要添加逻辑，以便在您的月度数据全部复制后对其进行排序
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
【讨论】：
这是部分伪代码，但你会想要这样的：
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
【讨论】：
如果这只是一次性练习，作为一种更简单的替代方法，您可以将过滤器应用于源数据，然后将过滤后的行复制并粘贴到新工作表中？
【讨论】：