3

Excel 2003 で、あるワークシートから別のワークシートに条件付きで行をコピーするマクロまたは方法はありますか?

Web クエリを介して SharePoint から Excel の空白のワークシートにデータのリストを取得し、特定の月の行を特定のワークシートにコピーしたいと考えています (たとえば、SharePoint ワークシートから 7 月のすべてのデータを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から最新のデータを引っ張ってきて、毎月の結果を見ることができるダッシュボードをまとめようとしているので、常にそれを実行でき、きれいに整理できる必要があります。

4

5 に答える 5

5

これはうまくいきます: 設定方法 私は直接ペインから呼び出しましたが、MoveData を毎月 1 回呼び出す 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
于 2008-09-17T15:38:42.860 に答える
1

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
于 2008-09-17T20:35:13.023 に答える
0

これを手動で行う方法は次のとおりです。

  • データの使用 - オートフィルター
  • 日付範囲に基づいてカスタム フィルターを適用する
  • フィルタリングされたデータを関連する月のシートにコピーします
  • 毎月繰り返す

以下に、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
于 2008-09-18T16:40:35.420 に答える
0

これは部分的に疑似コードですが、次のようなものが必要になります。 

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
于 2008-09-17T15:31:10.960 に答える
-1

これが 1 回限りの演習である場合、より簡単な代替手段として、ソース データにフィルターを適用し、フィルター処理された行をコピーして新しいワークシートに貼り付けることができますか?

于 2008-09-17T15:24:06.297 に答える