Extracting rows from excel Solved/Closed

Question

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

vcoolio · Accepted Answer

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.

Extracting rows from excel

1 response

Similar discussions

Subscribe To Our Newsletter!