?
Solved

Creating excel workbooks based on different values in a column

Posted on 2014-03-06
5
Medium Priority
?
1,006 Views
Last Modified: 2014-03-13
Hi,

I want to write a vbscript to be able to create new workbooks based on different values in a column: e.g.


Data Type
aaa    A-B
aaa    A-B
bbb   B-C
rrr     C-D
eee   B-C


If i have data in an excel sheet like above, i need to have three excel workbooks created in a folder, such that:
1st workbook should be A-B.xls which has elements with type A-B, 2nd workbook should be B-C which has elements with type B-C, and the 3rd workbook should have elements with type C-D.

Please advice.

Thanks,
Aditya
0
Comment
Question by:adirisin
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2
  • 2
5 Comments
 
LVL 12

Expert Comment

by:Harry Lee
ID: 39911372
adirisin,

Try the following code. MAKE BACKUP OF YOUR ORIGINAL DATA SHEET!!!

Sub CreateFilesBasedOnData()
Dim NFN As String, FPath As String, NFFN As String, SourceWS As Worksheet, SourceWB As Workbook, CurrWS As Worksheet
Dim ClmnNum As Long, RwCnt As Long, RwCnt2 As Long, LstRW As Long, I As Long, I2 As Long

Set SourceWB = ActiveWorkbook
Set SourceWS = ActiveSheet
FPath = "C:\Data\"

ClmnNum = Application.WorksheetFunction.Match("Type", Rows(1), 0)
Columns(ClmnNum).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D1" _
        ), Unique:=True
RwCnt = Cells(Rows.Count, 4).End(xlUp).Row
RwCnt2 = Cells(Rows.Count, 2).End(xlUp).Row

For I = 2 To RwCnt
    NFN = Cells(I, 4) & ".xlsx"
    NFFN = FPath & NFN
    Workbooks.Add
    Set CurrWS = ActiveSheet
    SourceWS.Activate
    Range("1:1").Copy
    CurrWS.Activate
    Range("A1").Select
    CurrWS.Paste
    LstRW = CurrWS.Cells(Rows.Count, 1).End(xlUp).Row
    
    For I2 = 2 To RwCnt2
        If SourceWS.Cells(I2, ClmnNum) = SourceWS.Cells(I, 4) Then
            SourceWS.Cells(I2, ClmnNum).EntireRow.Copy
            LstRW = LstRW + 1
            CurrWS.Activate
            CurrWS.Cells(LstRW, 1).Select
            CurrWS.Paste
        End If
    Next
    CurrWS.Range("C:D").Delete
Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=NFFN
    ActiveWorkbook.Close
Application.DisplayAlerts = True
Next

ActiveSheet.Columns(ClmnNum + 1).Delete
ActiveSheet.Columns(ClmnNum + 1).Delete

End Sub

Open in new window

0
 

Author Comment

by:adirisin
ID: 39911586
Hi,

Thanks for the solution. I am looking for VBscript, let me know if it is possible using that.

Aditya
0
 
LVL 12

Accepted Solution

by:
Harry Lee earned 2000 total points
ID: 39914154
adirisin,

I had been running tests all day to get this to work.

I believe you will have to make a lots of changes since I believe your actual data file is much bigger than the example data you have provided.

Option Explicit
Dim xlApp
Dim NFN, FPath, NFFN, xlSourceWS, xlSourceWB, CurrWS, xlListWS, xlListWB
Dim ClmnNum, RwCnt, RwCnt2, LstRW, I, I2
Dim fso
Dim ListFile, TgrPath

' You need to change "C:\Data\VBSTest.xls" to whatever file carrying the list you mentioned in the question
ListFile = "C:\Data\VBSTest.xls"

' You need to set where you want to save the files
FPath = "C:\Data\"

Set fso = CreateObject("Scripting.FileSystemObject")

If (fso.FileExists(ListFile)) Then
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlSourceWB = xlApp.Workbooks.Open(ListFile, 0, True)
    Set xlSourceWB = xlApp.ActiveWorkbook
    Set xlListWB = xlApp.Workbooks.Add()
    Set xlSourceWS = xlSourceWB.Worksheets("Sheet1")
    Set xlListWS = xlListWB.Worksheets("Sheet1")

    xlSourceWS.Range("B:B").AdvancedFilter 2, xlSourceWS.Range("B:B"), xlListWS.Range("A1"), True
    RwCnt = xlListWS.UsedRange.Rows.Count
    RwCnt2 = xlSourceWS.UsedRange.Rows.Count

    For I = 2 To RwCnt Step 1
        NFN = xlListWS.Cells(I, 1).Value & ".xlsx"
        NFFN = FPath & NFN
        xlApp.Workbooks.Add
        Set CurrWS = xlApp.ActiveSheet
        xlSourceWS.Activate
        xlSourceWS.Range("1:1").Copy
        CurrWS.Activate
        CurrWS.Range("A1").Select
        CurrWS.Paste
        LstRW = CurrWS.UsedRange.Rows.Count

        For I2 = 2 To RwCnt2 Step 1
            If xlSourceWS.Cells(I2, 2) = xlListWS.Cells(I, 1) Then
                xlSourceWS.Cells(I2, 2).EntireRow.Copy
                LstRW = LstRW + 1
                CurrWS.Activate
                CurrWS.Cells(LstRW, 1).Select
                CurrWS.Paste
            End If
        Next
        CurrWS.Range("C:D").Delete
	CurrWS.Range("A1").Select
	xlApp.Application.DisplayAlerts = False
        xlApp.ActiveWorkbook.SaveAs NFFN
        xlApp.ActiveWorkbook.Close
	xlApp.Application.DisplayAlerts = True
    Next

    xlApp.Application.DisplayAlerts = False
    xlSourceWB.Close
    xlListWB.Close
    xlApp.Application.DisplayAlerts = True

    xlApp.Quit
    Else
    WScript.Echo ("File does not exist!")
End If
WScript.Quit()

Open in new window

0
 

Author Closing Comment

by:adirisin
ID: 39926226
with slight customizations, i was able to get what i wanted. Thanks so much Harry!!
0

Featured Post

On Demand Webinar - Networking for the Cloud Era

This webinar discusses:
-Common barriers companies experience when moving to the cloud
-How SD-WAN changes the way we look at networks
-Best practices customers should employ moving forward with cloud migration
-What happens behind the scenes of SteelConnect’s one-click button

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

In this article we want to have a look at the directory attributes which are used by Microsoft to store the so called Security Identifiers (SID). These SIDs plays an important role in delegating and granting permissions and in authentication of trus…
Well hello again!  Glad to see you've made it this far without giving up.  In this, the fourth installment of my popular series, I'm going to cover functions and subroutines, what they are, and why they are useful.  Just in case you stumbled onto th…
Michael from AdRem Software explains how to view the most utilized and worst performing nodes in your network, by accessing the Top Charts view in NetCrunch network monitor (https://www.adremsoft.com/). Top Charts is a view in which you can set seve…
In this video, Percona Solution Engineer Dimitri Vanoverbeke discusses why you want to use at least three nodes in a database cluster. To discuss how Percona Consulting can help with your design and architecture needs for your database and infras…
Suggested Courses
Course of the Month11 days, 5 hours left to enroll

770 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question