vba code for copy specific data to another sheet

Maybe:

Sub rishikrsaw()
Dim ws As Worksheet
Dim rcell As Range
Dim wbk As Workbook
Dim i As Long
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set ws = ActiveSheet
On Error Resume Next
For Each rcell In Range("A2:A" & Range("A" & Rows.count).End(3)(1).Row)
        Workbooks.Add
        ActiveWorkbook.SaveAs rcell.Value
        Rows(1).Value = ws.Rows(1).Value
        ActiveSheet.Name = rcell.Value
ws.Activate
Next rcell
For Each wbk In Workbooks
    If Left(wbk.Name, 4) = "Book" Then
        wbk.Close
    End If
Next wbk
ws.Activate
For i = 2 To Range("A" & Rows.count).End(3)(1).Row
    Rows(i).Copy Workbooks(Range("A" & i).Value & ".xlsx").Sheets(Range("A" & i).Value).Range("A" & Rows.count).End(3)(2)
Next i
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Hi, John,

using SaveAs and assuming that a user who indicates 2007/2010 as used Excelversion uses *.xls as Standard File is a bit off the target for me and maybe one reason for an error (maybe refer to Ron de Bruin on SaveAs from 2007 on).

Besides: building an array with unique names and applying the Autofilter while looping through the array could prove to be a far more elegant way.

Ciao,
Holger.

Hi, rishikrsaw,

both procedures go into the same Standard Module:

Private Sub FindUniqueItems(UniqueItems As Variant, FilterRange As String)
' basic: ERLANDSEN DATA CONSULTING, http://www.erlandsendata.no/downloads/filterandprint.zip
' returns a list containing all unique items in the filter range
Dim TempList() As String, UniqueCount As Integer, cl As Range, i As Integer
    Range(FilterRange).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    UniqueCount = Range(FilterRange).SpecialCells(xlCellTypeVisible).Count
    ReDim TempList(1 To UniqueCount - 1)
    i = 0
    For Each cl In Range(FilterRange).SpecialCells(xlCellTypeVisible)
        i = i + 1
        If i > 1 Then TempList(i - 1) = cl.Formula ' ignore the heading
    Next cl
    Set cl = Nothing
    UniqueItems = TempList
    With ActiveSheet
      .ShowAllData
    End With
End Sub

Sub EF1023881()
Dim ItemList      As Variant
Dim lngC          As Long
Dim lngLastRow    As Long
Dim ws            As Worksheet
Dim rngCur        As Range
Dim rngCopy       As Range
Dim FileExtStr    As String
Dim FileFormatNum As String

Select Case ThisWorkbook.FileFormat
  Case 51
    FileExtStr = ".xlsx"
    FileFormatNum = 51
  Case 52:
    If ThisWorkbook.HasVBProject Then
      FileExtStr = ".xlsm"
      FileFormatNum = 52
    Else
      FileExtStr = ".xlsx"
      FileFormatNum = 51
    End If
  Case 56
    FileExtStr = ".xls"
    FileFormatNum = 56
  Case Else
    FileExtStr = ".xlsb"
    FileFormatNum = 50
End Select

Set ws = Workbooks("Book2.xlsx").Sheets("Master")
lngLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
FindUniqueItems ItemList, Range("A1:A" & lngLastRow).Address

Set rngCur = ws.Range("A1").CurrentRegion
Set ws = Nothing

For lngC = 1 To UBound(ItemList)
  rngCur.AutoFilter _
        field:=1, _
        Criteria1:=ItemList(lngC)
  Set rngCopy = rngCur.SpecialCells(xlCellTypeVisible)
  
  Workbooks.Add xlWBATWorksheet
  rngCopy.Copy Range("A1")
  
  ActiveSheet.Name = ItemList(lngC)
  ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ItemList(lngC) & FileExtStr, FileFormatNum
  ActiveWorkbook.Close False
Next lngC
rngCur.AutoFilter

Set rngCopy = Nothing
Set rngCur = Nothing

End Sub

This will take the path where to save the workbooks from the workbook with the code as well as when trying to make up what extension to use for the new workbooks.

How to install your new code

1. Copy the Excel VBA code
2. Select the workbook in which you want to store the Excel VBA code
3. Press Alt+F11 to open the Visual Basic Editor
4. Choose Insert > Module
5. Edit > Paste the macro into the module that appeared
6. Close the VBEditor
7. Save your workbook (Excel 2007+ select a macro-enabled file format, like *.xlsm)

To run the Excel VBA code:

1. Press Alt-F8 to open the macro list
2. Select a macro in the list
3. Click the Run button

Ciao,
Holger