Copy data from one sheet to other sheets if certain cells contain data

[mattadams84]

Hello,

I am looking to create a VBA script that will copy over data from a range of cells to another sheet. The scenario i have is a spreadsheet that collates football match results from across the world. I have a sheet named "Latest Results" and then two other sheets, "O1.5" and "O2.5" which have all the results collated since i started collecting data. Each evening i add the next days matches to each sheet and at the end of the day once the matches have been played I use a piece of software which populates the latest results sheet and then i manually copy the results to the other two pages. However what i would like to do is have a macro that checks if a match has a result on the latest result page, then i would like it to copy that result in to the corresponding cells on the other two pages and then delete it from the latest results page.

So, 1 match equals one row and there are 4 columns which contain the match data : date, league, home team, away team. There are then 7 columns which contain the result data. I guess the macro would need to look at each row (match) on the latest result page, see if it has a result, and if it does, see if that row exists on the other two pages. If this is true then it would copy the 7 columns of result data over to the other two pages and then delete the row from the latest result page.

This is an exteremely complicated request so if anyone can help me i would be grateful. I have attached a link to my spreadsheet so you can see it more clearly.

https://1drv.ms/x/s!Aqt6z2wNNUtZg9d5YtUKvQ-1zFb-LA

Kind regards

 

[mumps]

Try this macro. It may take 5 seconds or more to run because it uses loops.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim sAddr As String
    Dim x As Long
    Dim LastRow As Long
    LastRow = Sheets("Latest Results").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim visRng As Range
    Dim LastRow1 As Long
    LastRow1 = Sheets("O1.5").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim competition As Range
    Dim foundCompetition As Range
    Sheets("O1.5").Activate
    Range("AK4").Select
    Selection.AutoFilter
    ActiveSheet.Range("A1:A" & LastRow1).AutoFilter Field:=37, Criteria1:="="
    Set visRng = ActiveSheet.Range("C2:C" & LastRow1).SpecialCells(xlCellTypeVisible)
    For x = LastRow To 2 Step -1
        Set foundCompetition = visRng.Find(Sheets("Latest Results").Cells(x, "C"), LookIn:=xlValues, lookat:=xlWhole)
        If Not foundCompetition Is Nothing Then
            sAddr = foundCompetition.Address
            Do
                If Sheets("Latest Results").Cells(x, "D") = foundCompetition.Offset(0, 1) And Sheets("Latest Results").Cells(x, "E") = foundCompetition.Offset(0, 2) Then
                    Sheets("Latest Results").Range("F" & x & ":L" & x).Copy Sheets("O1.5").Range("AK" & foundCompetition.Row)
                    Sheets("Latest Results").Range("F" & x & ":L" & x).Copy Sheets("O2.5").Range("AK" & foundCompetition.Row)
                    Sheets("Latest Results").Rows(x).EntireRow.Delete
                End If
                Set foundCompetition = visRng.FindNext(foundCompetition)
            Loop While foundCompetition.Address <> sAddr
            sAddr = ""
        End If
    Next x
    Set foundCompetition = Nothing
    If Sheets("O1.5").FilterMode Then Sheets("O1.5").ShowAllData
    Application.ScreenUpdating = True
End Sub

 

[mattadams84]

Hi mumps,

Wow! Many thanks for your response and for your code, it works! I do however notice one small problem which i dont know can be resolved. I have for example just updated the spreadsheet with the latest results. However there were 4 matches that have not finished so dont yet have a result. When i ran the macro is succusfully copied the results over to the other two pages, and deleted them from latest results, however the 4 matches that had no results on the latest results page also got deleted. Is there anyway to keep them there until they get a result?

Many, many thanks for your help!

 

[mumps]

Replace this line:

If Sheets("Latest Results").Cells(x, "D") = foundCompetition.Offset(0, 1) And Sheets("Latest Results").Cells(x, "E") = foundCompetition.Offset(0, 2) Then

with this line:

If Sheets("Latest Results").Cells(x, "D") = foundCompetition.Offset(0, 1) And Sheets("Latest Results").Cells(x, "E") = foundCompetition.Offset(0, 2) And Sheets("Latest Results").Cells(x, "F") <> "" Then

 

[mattadams84]

Incredible, thank you so much! It works perfectly. I really really appreciate your help!

 

[mumps]

You are very welcome.