Consulting

Results 1 to 3 of 3

Thread: Solved: Copy current data to a new sheet....

  1. #1

    Solved: Copy current data to a new sheet....

    I have an application that collects data simply appending the new data at the end...
    I need to take this data, allow the user to select a month and a year, and have my macro copy all the relevant data to a new sheet.
    Attached is sample of the data and the start of my user form.
    the date that I am looking at is always in column D. The format is text and the date is formatted as m/d/y. I just want to compare what the user has entered to the m and y portions. Regular expressions? is this easier if the Date column is formatted as "date" instead of "text"?

    Thanks in advance for any guidance.
    David

  2. #2
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,453
    Location
    [vba]

    Private Sub CommandButton1_Click()
    mO = TextBox1.Value
    yr = TextBox2.Value
    Call CopyData(Val(mO), Val(yr))
    Unload Me
    End Sub

    Function CopyData(mth As Long, yr As Long)
    Const FORMULA_TEST As String = _
    "=AND(MONTH(D2)=<month>,YEAR(D2)=<year>)"
    Dim rng As Range
    Dim airea As Range
    Dim Lastrow As Long
    Dim Nextrow As Long

    With Worksheets("Raw Import")

    .Rows(1).Insert
    .Range("O1").Value = "Tmp"
    Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    .Range("O2").Resize(Lastrow - 1).Formula = Replace(Replace(FORMULA_TEST, _
    "<month>", mth), _
    "<year>", yr)
    Set rng = .Range("A1").Resize(Lastrow, 15)
    rng.AutoFilter field:=15, Criteria1:="=TRUE"
    On Error Resume Next
    Set rng = rng.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not rng Is Nothing Then

    Nextrow = 1
    For Each airea In rng.Areas

    airea.EntireRow.Copy Worksheets(2).Cells(Nextrow, "A")
    Nextrow = Nextrow + airea.Rows.Count
    Next airea
    Worksheets(2).Columns(15).Delete
    Worksheets(2).Rows(1).Delete
    End If
    .Columns(15).Delete
    .Rows(1).Delete
    End With

    End Function
    [/vba]
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  3. #3

    Solved! Wow...

    You know what's better than having a solution to a problem...
    Being able to learn form that solution!

    You Rock!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •