Excel macro to copy/paste every nth rows

[jay36429]

Hi,

I have a list of 40,000 football matches played. Data is in the format of

11:45 +00:00, August 19, 2006
Sheffield United v Liverpool - Barclays Premier League - ESPN Soccernet
Score : 1 - 1
Goals scored by Sheffield United : 1
Time : 46',
Goals scored by Liverpool : 1
Time : pen 70',
Yellow Cards : 1 - 2
Yellow Cards time : 37', 64', 82',
Red Cards : 0 - 0
Red Cards time :
********************

The cell count starts with A1 and goes on till the end of the sheet. The data is in a standard format. Data is present in the 1st 11 cells i.e A1:A11 which is then seperated by a "********************" followed by 5 blank cells and followed by the data for the next match. I have the paste the values into the next sheet with the headers
(Date, Team, Score, Home Goals, Time of Home Goals, Away Goals, Time of Away Goals, Yellow Cards, Yellow Cards time, Red Cards, Red Cards Time)
which is 11 row heads followed by 40000 match details.
Any sugesstions. I am not a macro person so I might find this quite challenging.

 

[Snakehips]

jay36429,

Under header Team do you want teams?
or
Date, Home team,Home goals ........ Awat Team, Away goals......?

 

[hiker95]

jay36429,


Welcome to the MrExcel forum.


I assume that worksheet Sheet1 contains your raw data in column A, and there is no other information in the worksheet.


Sample raw data in worksheet Sheet1, before and after the macro:

Excel Workbook
	A
1	11:45 +00:00, August 19, 2006
2	Sheffield United v Liverpool - Barclays Premier League - ESPN Soccernet
3	Score : 1 - 1
4	Goals scored by Sheffield United : 1
5	Time : 46',
6	Goals scored by Liverpool : 1
7	Time : pen 70',
8	Yellow Cards : 1 - 2
9	Yellow Cards time : 37', 64', 82',
10	Red Cards : 0 - 0
11	Red Cards time :
12	********************
13
14
15
16
17
18	11:45 +00:00, August 19, 2006
19	Sheffield United v Liverpool - Barclays Premier League - ESPN Soccernet
20	Score : 1 - 1
21	Goals scored by Sheffield United : 1
22	Time : 46',
23	Goals scored by Liverpool : 1
24	Time : pen 70',
25	Yellow Cards : 1 - 2
26	Yellow Cards time : 37', 64', 82',
27	Red Cards : 0 - 0
28	Red Cards time :
29	********************
30
31
32
33
34
35	11:45 +00:00, August 19, 2006
36	Sheffield United v Liverpool - Barclays Premier League - ESPN Soccernet
37	Score : 1 - 1
38	Goals scored by Sheffield United : 1
39	Time : 46',
40	Goals scored by Liverpool : 1
41	Time : pen 70',
42	Yellow Cards : 1 - 2
43	Yellow Cards time : 37', 64', 82',
44	Red Cards : 0 - 0
45	Red Cards time :
46	********************
47
Sheet1

After the macro in a new worksheet Results:

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K
1	Date	Team	Score	Home Goals	Time of Home Goals	Away Goals	Time of Away Goals	Yellow Cards	Yellow Cards time	Red Cards	Red Cards time
2	August 19, 2006	Sheffield United v Liverpool - Barclays Premier League - ESPN Soccernet	1 - 1	1	46'	1	pen 70'	1 - 2	37', 64', 82'	0 - 0
3	August 19, 2006	Sheffield United v Liverpool - Barclays Premier League - ESPN Soccernet	1 - 1	1	46'	1	pen 70'	1 - 2	37', 64', 82'	0 - 0
4	August 19, 2006	Sheffield United v Liverpool - Barclays Premier League - ESPN Soccernet	1 - 1	1	46'	1	pen 70'	1 - 2	37', 64', 82'	0 - 0
5
Results

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Option Base 1
Sub ReorgData()
' hiker95, 11/07/2011
' http://www.mrexcel.com/forum/showthread.php?t=590388
Dim w1 As Worksheet, wR As Worksheet
Dim A(), I(), O()
Dim lr As Long, r As Long, rr As Long
Set w1 = Worksheets("Sheet1")
lr = w1.Cells(Rows.Count, 1).End(xlUp).Row
A = w1.Range("A1:A" & lr)
On Error Resume Next
w1.Range("A1:A" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
lr = w1.Cells(Rows.Count, 1).End(xlUp).Row
rr = Application.CountIf(w1.Columns(1), "Score :*")
I = w1.Range("A1:A" & lr)
w1.Range("A1").Resize(UBound(A)) = A
ReDim O(1 To rr + 1, 1 To 11)
O(1, 1) = "Date"
O(1, 2) = "Team"
O(1, 3) = "Score"
O(1, 4) = "Home Goals"
O(1, 5) = "Time of Home Goals"
O(1, 6) = "Away Goals"
O(1, 7) = "Time of Away Goals"
O(1, 8) = "Yellow Cards"
O(1, 9) = "Yellow Cards time"
O(1, 10) = "Red Cards"
O(1, 11) = "Red Cards time"
rr = 1
For r = 1 To UBound(I) Step 12
  rr = rr + 1
  O(rr, 1) = Right(I(r, 1), Len(I(r, 1)) - Application.Find(",", I(r, 1), 1) - 1)
  O(rr, 2) = I(r + 1, 1)
  If Len(I(r + 2, 1)) > 8 Then O(rr, 3) = Right(I(r + 2, 1), Len(I(r + 2, 1)) - 8)
  If Len(I(r + 3, 1)) > 35 Then O(rr, 4) = Right(I(r + 3, 1), Len(I(r + 3, 1)) - 35)
  If Len(I(r + 4, 1)) > 7 Then O(rr, 5) = Right(I(r + 4, 1), Len(I(r + 4, 1)) - 7)
  If Right(O(rr, 5), 2) = ", " Then O(rr, 5) = Left(O(rr, 5), Len(O(rr, 5)) - 2)
  If Len(I(r + 5, 1)) > 28 Then O(rr, 6) = Right(I(r + 5, 1), Len(I(r + 5, 1)) - 28)
  If Len(I(r + 6, 1)) > 7 Then O(rr, 7) = Right(I(r + 6, 1), Len(I(r + 6, 1)) - 7)
  If Right(O(rr, 7), 2) = ", " Then O(rr, 7) = Left(O(rr, 7), Len(O(rr, 7)) - 2)
  If Len(I(r + 7, 1)) > 15 Then O(rr, 8) = Right(I(r + 7, 1), Len(I(r + 7, 1)) - 15)
  If Len(I(r + 8, 1)) > 20 Then O(rr, 9) = Right(I(r + 8, 1), Len(I(r + 8, 1)) - 20)
  If Right(O(rr, 9), 2) = ", " Then O(rr, 9) = Left(O(rr, 9), Len(O(rr, 9)) - 2)
  If Len(I(r + 9, 1)) > 12 Then O(rr, 10) = Right(I(r + 9, 1), Len(I(r + 9, 1)) - 12)
  If Len(I(r + 10, 1)) > 17 Then O(rr, 11) = Right(I(r + 10, 1), Len(I(r + 10, 1)) - 17)
Next r
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
wR.Range("A1").Resize(UBound(O), 11).NumberFormat = "@"
wR.Range("A1").Resize(UBound(O), 11) = O
wR.UsedRange.Columns.AutoFit
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the ReorgData macro.



If the above does not work correctly with your actual data, then can we have some screenshots of before and after?

To attach screenshots, see below in my Signature block: Post a screen shot with one of these:

 

[jay36429]

Hey Thanks a tonne. Works like a Gem. You guys are fabulous

 

[Snakehips]

Too late I fear but here is my offering, coded in a different way.

I had assumed that you would not want to retain the 'Barclays Premier..' so trimmmed it off.

Source data assumed to be in sheet named "Source Data".

Sub ListMatches()

Dim Source As Range
Dim Dest As Range

Sheets.Add.Name = "Match List"
Set Source = ThisWorkbook.Sheets("Source Data").Range("A1")

Set Dest = ThisWorkbook.Sheets("Match List").Range("B1")
Sheets("Match List").Columns.NumberFormat = "@"
Dest.Value = "Date"
Dest.Offset(0, 1).Value = "Teams"
Dest.Offset(0, 2).Value = "Score"
Dest.Offset(0, 3).Value = "Home Goals"
Dest.Offset(0, 4).Value = "Time HG"
Dest.Offset(0, 5).Value = "Away Goals"
Dest.Offset(0, 6).Value = "Time AG"
Dest.Offset(0, 7).Value = "Yellow Cards"
Dest.Offset(0, 8).Value = "YC Time"
Dest.Offset(0, 9).Value = "Red Cards"
Dest.Offset(0, 10).Value = "RC Time"
Dest.EntireRow.RowHeight = 25
Dest.EntireRow.WrapText = True

Mnum = 1

Do While Mnum > 0
Mdate = Source.Value
Mdate = Trim$(Right$(Mdate, Len(Mdate) - InStr(Mdate, ",")))
Mteams = Source.Offset(1, 0).Value
Mteams = Left$(Mteams, Len(Mteams) - 20)
Mteams = Trim$(Left$(Mteams, InStr(Mteams, "-") - 1))
Mscore = Source.Offset(2, 0).Value
Mscore = Trim$(Right$(Mscore, Len(Mscore) - InStr(Mscore, ":")))
Mgoalsh = Source.Offset(3, 0).Value
Mgoalsh = Trim$(Right$(Mgoalsh, Len(Mgoalsh) - InStr(Mgoalsh, ":")))
Mgtimeh = Source.Offset(4, 0).Value
Mgtimeh = Trim$(Right$(Mgtimeh, Len(Mgtimeh) - InStr(Mgtimeh, ":")))
Mgoalsa = Source.Offset(5, 0).Value
Mgoalsa = Trim$(Right$(Mgoalsa, Len(Mgoalsa) - InStr(Mgoalsa, ":")))
Mgtimea = Source.Offset(6, 0).Value
Mgtimea = Trim$(Right$(Mgtimea, Len(Mgtimea) - InStr(Mgtimea, ":")))
Myels = Source.Offset(7, 0).Value
Myels = Trim$(Right$(Myels, Len(Myels) - InStr(Myels, ":")))
Myelst = Source.Offset(8, 0).Value
Myelst = Trim$(Right$(Myelst, Len(Myelst) - InStr(Myelst, ":")))
Mreds = Source.Offset(9, 0).Value
Mreds = Trim$(Right$(Mreds, Len(Mreds) - InStr(Mreds, ":")))
Mredst = Source.Offset(10, 0).Value
Mredst = Trim$(Right$(Mredst, Len(Mredst) - InStr(Mredst, ":")))

Dest.Offset(Mnum, 0) = Mdate
Dest.Offset(Mnum, 1).Value = Mteams
Dest.Offset(Mnum, 2).Value = Mscore
Dest.Offset(Mnum, 3).Value = Mgoalsh
Dest.Offset(Mnum, 4).Value = Mgtimeh
Dest.Offset(Mnum, 5).Value = Mgoalsa
Dest.Offset(Mnum, 6).Value = Mgtimea
Dest.Offset(Mnum, 7).Value = Myels
Dest.Offset(Mnum, 8).Value = Myelst
Dest.Offset(Mnum, 9).Value = Mreds
Dest.Offset(Mnum, 10).Value = Mredst


Set Source = Source.Offset(17, 0)
If Source.Value = "" Then Mnum = -1
Mnum = Mnum + 1
Loop

Dest.Columns("A:K").EntireColumn.AutoFit

End Sub

To give ...

Excel Workbook
	B	C	D	E	F	G	H	I	J	K	L
1	Date	Teams	Score	Home Goals	Time HG	Away Goals	Time AG	Yellow Cards	YC Time	Red Cards	RC Time
2	August 19, 2006	Sheffield United v Liverpool	1 - 1	1	46',	1	pen 70',	1 - 2	37', 64', 82',	0 - 0
3	August 19, 2006	Sheffield United v Liverpool	1 - 1	1	46',	1	pen 70',	1 - 2	37', 64', 82',	0 - 0
4	August 19, 2006	Sheffield United v Coventry	1 - 1	1	46',	1	pen 70',	1 - 2	37', 64', 82',	0 - 0
Match List

 

[hiker95]

jay36429,

You are very welcome.

Glad I could help.

Thanks for the feedback.

Come back anytime.