Есть ли макрос для условного копирования строк на другой лист?

Question

Есть ли макрос или способ условно скопировать строки из одного листа в другой в Excel 2003?

Я перетаскиваю список данных из SharePoint с помощью веб-запроса в пустой лист в Excel, а затем хочу скопировать строки за конкретный месяц на конкретный лист (например, все данные за июль с листа SharePoint на Рабочий лист за июль, все данные за июнь с рабочего листа SharePoint на рабочий лист за июнь и т. Д.).

Пример данных

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 и просматривать результаты за месяц, поэтому он должен иметь возможность делать это все время и организовывать его аккуратно.

Answer 1

Это работает: как он настроен, я вызывал его из непосредственной панели, но вы можете легко создать подпрограмму (), которая будет вызывать 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

Answer 2

Это частично псевдокод, но вы захотите что-то вроде:

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

Answer 3

Вот еще одно решение, которое использует некоторые встроенные функции даты 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

Answer 4

Я бы сделал это вручную:

• Использовать данные - Автофильтр
• Применить пользовательский фильтр на основе диапазона дат
• Скопируйте отфильтрованные данные в соответствующий месячный лист
• Повторите для каждого месяца

Ниже приведен код для выполнения этого процесса через 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

Answer 5

Если это всего лишь одноразовое упражнение, то в качестве более простой альтернативы вы могли бы применить фильтры к исходным данным, а затем скопировать и вставить отфильтрованные строки в новую рабочую таблицу?