Help with Moving data between sheets based on Date value

[anewman5high]

Hi Guys,

I'm relatively new to VBA (I bet you haven't heard that before) and am working on a Master spreadsheet to store some basic research funding application info and report on it. Each row in the main data sheet has a reference number (Column A) for the funding round that it was submitted in and the submission date (Column H). The reference number is repeated along all applications submitted in that round (anywhere between 2 and 100 in total).

The code I have made so far asks for a date range and copies the reference for each application submitted in that range to a new sheet and then removes all duplicates so I have a list of unique rounds that occurred within that year.

It then pulls out information based on the same date range but groups it by board meeting (Column O) instead of funding round.

This seems to work but is running very slowly and the results end up with a blank cell in the column between each unique result. Nothing I have been able to do will speed it up or get rid of the blank cells. I think the speed issue is down to the search looping through the sheet but am not experienced enough to fix it!

The code I have is below, I would be very grateful if anyone is able to point me in the right direction to fix this! I have had a search round the forums but can't find what I need!

I will also need to build on this to search and pull through additional data from the same columns in a 3rd sheet ("Archive") but I'm sure I can work out how to adapt it to this if the rest is fixed!

Thanks in advance!
Alan

Sub Run_Report()

    Dim startdate As Date, enddate As Date
    Dim rng As Range, destRow As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim c As Range
    Application.ScreenUpdating = False


    Set shtSrc = Sheets("Researcher-Led")
    Set shtDest = Sheets("Reporting")


    destRow = 13 'start copying to this row


    startdate = CDate(InputBox("Begining Date"))
    enddate = CDate(InputBox("End Date"))


    
    Set rng = Application.Intersect(shtSrc.Range("H:H"), shtSrc.UsedRange)


    For Each c In rng.Cells
        If c.Value >= startdate And c.Value <= enddate Then
                        c.Offset(0, -7).Resize(1, 1).Copy _
                          shtDest.Cells(destRow, 2)
                        


            destRow = destRow + 1
            
            ActiveSheet.Rows("13:999").RowHeight = 15
            ActiveSheet.Cells.VerticalAlignment = xlTop
            ActiveSheet.Cells.HorizontalAlignment = xlLeft
            
        


        End If
        If c.Value >= startdate And c.Value <= enddate Then
                        c.Offset(0, 7).Resize(1, 1).Copy _
                          shtDest.Cells(destRow, 20)


            destRow = destRow + 1
            
            ActiveSheet.Rows("13:999").RowHeight = 15
            ActiveSheet.Cells.VerticalAlignment = xlTop
            ActiveSheet.Cells.HorizontalAlignment = xlLeft
    End If
    Next


    Range("B13:B19").Select
    ActiveSheet.Range("$B$12:$B$999").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("T13:T19").Select
    ActiveSheet.Range("$T$12:$T$999").RemoveDuplicates Columns:=1, Header:=xlYes
    
End Sub

 

[Fluff]

Hi & welcome to MrExcel
I have made a couple of assumptions for this
1) That each pair of copied cells should go on the same row.
2) That the formatting & remove duplicates should be done on the Report sheet

Sub Run_Report()

    Dim startdate As Date, enddate As Date
    Dim rng As Range, destRow As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim c As Range
    Application.ScreenUpdating = False


    Set shtSrc = Sheets("Researcher-Led")
    Set shtDest = Sheets("Reporting")


    destRow = 13 'start copying to this row


    startdate = CDate(InputBox("Begining Date"))
    enddate = CDate(InputBox("End Date"))


    
    Set rng = shtSrc.Range("H1", shtSrc.Range("H" & Rows.Count).End(xlUp))


    For Each c In rng
        If c.Value >= startdate And c.Value <= enddate Then
            c.Offset(0, -7).Copy shtDest.Cells(destRow, 2)
            c.Offset(0, 7).Copy shtDest.Cells(destRow, 20)
            
            destRow = destRow + 1

        End If
    Next c
    
    With shtDest
        .Rows("13:999").RowHeight = 15
        .Cells.VerticalAlignment = xlTop
        .Cells.HorizontalAlignment = xlLeft
        
        .Range("$B$12:$B$999").RemoveDuplicates Columns:=1, Header:=xlYes
        .Range("$T$12:$T$999").RemoveDuplicates Columns:=1, Header:=xlYes
    End With
    
End Sub

 

[anewman5high]

Fluff,

That has worked perfectly, thank you for your help!

Just to clarify, I'm assuming the speed issue was because I had essentially asked it to do the same thing twice and to search all of the cells in column H instead of wrapping it up much neater as you did! The bit of still confused about was why it was adding an extra line between the results, are you able to shed any light on this?

Thanks again, you're a lifesaver! I've tried to like your post but apparently I don't have permission to do this!?

 

[Fluff]

Glad to help & thanks for the feedback.

Inside your loop you had two identical If statements so if the first is true, then so is the second. Therefore you were
a) formatting the sheet twice for every value in col H. (speed issue)
b) adding 1 to destRow twice. (hence extra lines)
HTH
as for

I've tried to like your post but apparently I don't have permission to do this!

You have both Thanked & Liked my post.

cheers