Extracting rows from excel [Solved/Closed]

Teke - Jan 27, 2016 at 06:43 PM - Latest reply: vcoolio 1159 Posts Thursday July 24, 2014Registration dateModeratorStatus March 28, 2018 Last seen
- 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
See more 

3 replies

vcoolio 1159 Posts Thursday July 24, 2014Registration dateModeratorStatus March 28, 2018 Last seen - Feb 1, 2016 at 05:33 AM
+2
Helpful
2
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
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value
        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.
Was this answer helpful?  
Dear vcoolio,
Thank you very much for your time and help. You really made my life easier.
vcoolio 1159 Posts Thursday July 24, 2014Registration dateModeratorStatus March 28, 2018 Last seen > Teke - Feb 1, 2016 at 04:48 PM
Hello Teke,

You're welcome. Glad that I could help.

Cheerio,
vcoolio.