# Extracting rows from excel

Solved/Closed
Teke - Jan 27, 2016 at 06:43 PM
vcoolio Posts 1409 Registration date Thursday July 24, 2014 Status Moderator Last seen May 23, 2024 - Feb 1, 2016 at 04:48 PM
Hi there,
I have an excel sheet with a very large data. I want to extract different rows and write them in to different sheets of the same excel (or a new excel) file. Can anyone help me please? Below is the sample data. I want to copy each "Chrom" type (1A...7D) in to a new sheet. Thank you so much for your help.

Name Chrom x y z
1 1A B B B
2 1B B B A
3 1D B B B
4 2A B B B
5 2B B B B
6 2D B B A
7 3A B A A
8 3B B B B
9 3D A A A
10 4A A A A
11 4B B B B
12 4D B B B
13 5A B B B
14 5B B B B
15 5D A A A
16 6A A A A
17 6B B B B
18 6D B B B
19 7A A A A
20 7B B B B
21 7D A A A
Related:

## 1 response

vcoolio Posts 1409 Registration date Thursday July 24, 2014 Status Moderator Last seen May 23, 2024 262
Feb 1, 2016 at 05:33 AM
Hello Teke,

I'm assuming that you would like a new sheet created for each "chrom" value and the relevant row of data transferred to each individual sheet. If so, try the following code (in a copy of your work book first):-

```Sub CreateSheetsCopyData()

Application.ScreenUpdating = False

Dim ar As Variant
Dim i As Integer
Dim LR As Long
Dim c As Range
Dim ws As Worksheet
Dim Mysheet As String

LR = Range("A" & Rows.Count).End(xlUp).Row
ar = Array("1A", "1B", "1D", "2A", "2B", "2D", "3A", "3B", "3D", "4A", "4B", "4D", "5A", "5B", "5D", "6A", "6B", "6D", "7A", "7B", "7D")

For Each c In Range("B2:B" & LR)
Set ws = Nothing
On Error Resume Next
Set ws = Worksheets(c.Value)
If ws Is Nothing Then
End If
Next c

Sheet1.Select
For i = 0 To UBound(ar)
Sheets(ar(i)).UsedRange.ClearContents
Range("B1", Range("B" & Rows.Count).End(xlUp)).AutoFilter 1, ar(i)
Range("A1", Range("E" & Rows.Count).End(xlUp)).Copy Sheets(ar(i)).Range("A" & Rows.Count).End(xlUp)
Next i
[B1].AutoFilter

Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Data transfer completed!", vbExclamation, "Status"

End Sub
```

Following is a link to my test work book for you to peruse. To run the code, Pess Alt + F8 to open the macro window then click on run.

https://www.dropbox.com/s/zjkkxceroy3e24i/Teke.xlsm?dl=0

I hope that this helps.

Cheerio,
vcoolio.
Dear vcoolio,
Thank you very much for your time and help. You really made my life easier.
vcoolio Posts 1409 Registration date Thursday July 24, 2014 Status Moderator Last seen May 23, 2024 262 > Teke
Feb 1, 2016 at 04:48 PM
Hello Teke,

You're welcome. Glad that I could help.

Cheerio,
vcoolio.