Creating Separate sheet - VBA

Hi Experts,

i have little problem with excel macro, I have workbook name "master" in which i have 52 sheets, if i select all sheets & then do some process (which is happen with all sheets) .the one sheet which mi working process is perfect but in rest sheets data is not properly processed which i desire. Just look in to steps which i want do with data all sheet data.

Step 1   Copy cell A2 & B2 & fill down till data in column C


Step 2  Move Or Copy - Create a copy - new book

Step 3 save new book in name of sheet (excel version 97 - 2003) & same for whole 52 sheet (save differently i.e. individual workbook) like sheet4.xls , sheet5.xls , sheet6.xls & so on


i am attaching "Master" workbook & result workbook
in sheet you will see what i want it.

so there is any macro to minimize this lengthy process.

pls help me out

Thank You
Master.xlsm
NZ1-Index.xls
itjockey79Asked:
Who is Participating?
 
itjockey79Connect With a Mentor Author Commented:
Option Explicit

Public Sub Q_27753012()
    Dim wkbMaster As Workbook
    Dim wks As Worksheet
    Dim wkb As Workbook
    Dim rng As Range
    Const cPath As String = "C:\Users\Administrator\Desktop\Data\"
    Set wkbMaster = Application.Workbooks("Master.xls") 'assume this is already open
    Application.ScreenUpdating = False
    For Each wks In wkbMaster.Worksheets
        Set wkb = Application.Workbooks.Add
        wkb.Worksheets(1).Name = wks.Name
        wks.Range("A1:B1").CurrentRegion.Copy wkb.Worksheets(1).Range("A1:B1")
        Set rng = wkb.Worksheets(1).Range("A2:B2")
        Set rng = wkb.Worksheets(1).Range(rng, wkb.Worksheets(1).Cells(rng.CurrentRegion.Rows.Count, 1))
        rng.FillDown
        wkb.SaveAs cPath & wkb.Worksheets(1).Name, 56        '56 = xlExcel8
        wkb.Close
    Next
    wkbMaster.Close
    Application.ScreenUpdating = True
End Sub
0
 
itjockey79Author Commented:
i have one code but that do some different process then this but pretty much similar,


Option Explicit

Public Sub Q_27753012()
    Dim wkbMaster As Workbook
    Dim wks As Worksheet
    Dim wkb As Workbook
    Dim rng As Range
    Const cPath As String = "C:\users\mark\downloads\"
    Set wkbMaster = Application.Workbooks("Master.xls") 'assume this is already open
    Application.ScreenUpdating = False
    For Each wks In wkbMaster.Worksheets
        Set wkb = Application.Workbooks.Add
        wkb.Worksheets(1).Name = wks.Name
        wks.Range("A1").CurrentRegion.Copy wkb.Worksheets(1).Range("A1")
        Set rng = wkb.Worksheets(1).Range("A2")
        Set rng = wkb.Worksheets(1).Range(rng, wkb.Worksheets(1).Cells(rng.CurrentRegion.Rows.Count, 1))
        rng.FillDown
        Set rng = wkb.Worksheets(1).Range("G2")
        Set rng = wkb.Worksheets(1).Range(rng, wkb.Worksheets(1).Cells(rng.CurrentRegion.Rows.Count, 7))
        rng.FillDown
        rng.Value = rng.Value
        wkb.Worksheets(1).Range("I:J").EntireColumn.Delete
        wkb.SaveAs cPath & wkb.Worksheets(1).Name, 56        '56 = xlExcel8
        wkb.Close
    Next
    wkbMaster.Close
    Application.ScreenUpdating = True
End Sub

Open in new window

0
 
Saqib Husain, SyedEngineerCommented:
Sub fillNMovShts()
Dim ws As Worksheet
Dim fpath As String
fpath = "D:\temp\"
For Each ws In ThisWorkbook.Worksheets
ws.Select
Range("A2:B2").Copy Range("A2:A" & Range("C" & Rows.Count).End(xlUp).Row)
If ThisWorkbook.Worksheets.Count > 1 Then
ws.Move
ActiveWorkbook.SaveAs fpath & ActiveSheet.Name & ".xlsx"
ActiveWorkbook.Close
Else
ThisWorkbook.SaveAs fpath & ActiveSheet.Name & ".xlsx", xlExcel8
End If
Next ws
End Sub

Open in new window

0
Cloud Class® Course: Microsoft Exchange Server

The MCTS: Microsoft Exchange Server 2010 certification validates your skills in supporting the maintenance and administration of the Exchange servers in an enterprise environment. Learn everything you need to know with this course.

 
itjockey79Author Commented:
Code working perfect Sir but i want it .xls not .xlxs extension....pls little modification
0
 
Saqib Husain, SyedEngineerCommented:
Change the lines...(I have not tested it)

ActiveWorkbook.SaveAs fpath & ActiveSheet.Name & ".xlsx"
ThisWorkbook.SaveAs fpath & ActiveSheet.Name & ".xlsx", xlExcel8

to

ActiveWorkbook.SaveAs fpath & ActiveSheet.Name & ".xls"
ThisWorkbook.SaveAs fpath & ActiveSheet.Name & ".xls"
0
 
itjockey79Author Commented:
not working Sir...
0
 
Saqib Husain, SyedConnect With a Mentor EngineerCommented:
I wonder why. Here is the tested code.

Sub fillNMovShts()
Dim ws As Worksheet
Dim fpath As String
fpath = "D:\temp\"
For Each ws In ThisWorkbook.Worksheets
ws.Select
Range("A2:B2").Copy Range("A2:A" & Range("C" & Rows.Count).End(xlUp).Row)
If ThisWorkbook.Worksheets.Count > 1 Then
ws.Move
ActiveWorkbook.SaveAs fpath & ActiveSheet.Name & ".xls"
ActiveWorkbook.Close
Else
ThisWorkbook.SaveAs fpath & ActiveSheet.Name & ".xls"
End If
Next ws
End Sub

Open in new window

0
 
itjockey79Author Commented:
This is working Fine.....
0
 
itjockey79Author Commented:
I've requested that this question be closed as follows:

Accepted answer: 0 points for itjockey79's comment http:#a38328874
Assisted answer: 500 points for ssaqibh's comment http:#a38328655

for the following reason:

As code by expert is use full but after i had click on result file one pop up message come from MS &amp; i have to click yes, this files are use for convert this excel data to chart data for my software so in converting process error message came for all file so i had change my provided code with little some from expert &amp; it &nbsp;had worked...<br /><br /><br />Thank you Expert
0
 
Saqib Husain, SyedEngineerCommented:
If you want to accept your own answer then you should provide the solution that you used to complete the question.
0
 
Saqib Husain, SyedEngineerCommented:
Sorry, I did not realize that you had provided your solution. You can go ahead and close the question as you intended to.

Saqib
0
 
Saqib Husain, SyedEngineerCommented:
BTW if you add the

,56

to the end of both the saveas statements then my program will also work as expected.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.