Excel - Macro to conditionally copy rows to another worksheet

Does anyone have a macro or could point me to a way that I could conditionally copy rows from one worksheet to another in Excel 2003.

I'm pulling a list of data from Sharepoint via web query into a blank worksheet in Excel, and then I want to copy the rows for a particular month to a particular worksheet (e.g., all July data from Sharepoint worksheet to the Jul worksheet, all June data from 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

From stackoverflow $pageUsers[$entry.posts[0].author].name

• 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?

  From RickL

• 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
  

  From BKimmel

• 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
  

  From theo

• Thanks Theo - I'll have to give that a try.

  Unfortunately, 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.

  theo : No problem: Email me if you need a hand with it: theogeer@gmail.com
  From $pageUsers[$post.author].name

• 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
  

  From Jon Fournier

• 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
  

  From Robert Mearns

• Hello i am having some issue when am using two criterias,Can you please send me example VBscript with two or more criteria or for below example.

  In the below example I need to auto filter by 4 criteria’s

  From the main sheet I need to extract in the following way.

  1)steps one I need to extract only Active users = Testing into new sheet 1 Active users = Developer into new sheet 2 Active users = Integration into new sheet 3 Active users = all ..except (Testing,Developing,Integration) new sheet 4

  Column H we have Active & terminated and column G we have teams(testing,Intgration etc).

  From shankar85m