问题
Is there a macro or a way to conditionally copy rows from one worksheet to another in 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.).
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.
回答1:
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.
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
回答2:
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:
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
回答3:
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.
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
回答4:
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
回答5:
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?
来源：https://stackoverflow.com/questions/84331/is-there-a-macro-to-conditionally-copy-rows-to-another-worksheet