Extracting rows from excel

Solved/Closed
Teke - Jan 27, 2016 at 06:43 PM
vcoolio Posts 1411 Registration date Thursday July 24, 2014 Status Moderator Last seen September 6, 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 1411 Registration date Thursday July 24, 2014 Status Moderator Last seen September 6, 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
        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.
Dear vcoolio,
Thank you very much for your time and help. You really made my life easier.
vcoolio Posts 1411 Registration date Thursday July 24, 2014 Status Moderator Last seen September 6, 2024 262 > Teke
Feb 1, 2016 at 04:48 PM
Hello Teke,

You're welcome. Glad that I could help.

Cheerio,
vcoolio.