Can any one suggest how to write a macro for this...

Question

0.00/5 (No votes)

See more:

Hi All...
I Am New to macro's.... I have a Requirement in Excel to be done in Macro... i am trying to do it... But i am unable to figure out how to do... Any Help will be Appreciated...
My requirement is Like This...

DataInput: (Sheet1)

IN         OUT        Item             Unit       Date      Location
---------------------------------------------------------------------
AB         XY          Item1           No's      12-5-2013     IND
CD         BV          Item1           No's      12-5-2013     IND

ItemRouting:

Item         Routing
----------------------
Item1       Item1Route
Item2       Item2Route

Routing:

Routing       IN    OUT   RoutingSteps    Department
------------------------------------------------------
Item1Route    AB     XY     Step1          Procurement
Item1Route    AB     XY     Step2          Selling
Item2Route    CD     BV     Step1          Procurement
Item2Route    CD     BV     Step2          Selling

From the above data
1. I Have to Select a Routing(ColumnName)(From ItemRouting(Sheet Name)) based on Item (From DataInput(Sheet name))
2. Based on the Routing Selected From Step1,IN,Out(From DataInput) select the Routingsteps,Department(From Routing)
3.Based on the Department Selected i Have to copy the details in that particular Department(Sheet)...

For the Above example the output will be:
Procurement(Sheet):

IN   OUT   Item     Unit     Date        Location  RoutingStep  Department
--------------------------------------------------------------------------
AB    XY    Item1    N0's  12-5-2013       IND       Step1     Procurement
CD    BV    Item1    N0's  12-5-2013       IND       Step1     Procurement

Selling:

IN   OUT   Item     Unit     Date        Location  RoutingStep  Department
--------------------------------------------------------------------------
AB    XY    Item1    N0's  12-5-2013       IND       Step2     Selling
CD    BV    Item1    N0's  12-5-2013       IND       Step2     Selling

The code which i used is:

Option Explicit

Sub FindMacro()
    Dim DataInputRowCount As Long, RoutingRowCount As Long, DRowCount As Long
    Dim IpProductType As String, DataIN As String, DataOut As String, Routing As String,   Department As String, RoutingStep As String
    Dim I As Long, R As Long, Rowno As Long

    Sheets("DataInput").Activate
    DataInputRowCount = Cells(Cells.Rows.Count, 5).End(xlUp).Row

    For I = 2 To DataInputRowCount
        Sheets("DataInput").Activate
        IpProductType = Cells(I, 5).Value
        DataIN = Cells(I, 3).Value
        DataOut = Cells(I, 4).Value
        Rows(I).Copy

        Rowno = Sheets("ProductRouting").Columns(1).Find(IpProductType, , xlValues, xlWhole).Row
        Routing = Sheets("ProductRouting").Range("B" & Rowno).Value
        
        Sheets("Routing").Activate
        RoutingRowCount = Cells(Cells.Rows.Count, 1).End(xlUp).Row

        For R = 2 To RoutingRowCount
            Sheets("Routing").Activate
            If Cells(R, 1).Value = Routing And Cells(R, 2).Value = DataIN And Cells(R, 3).Value = DataOut Then
                RoutingStep = Cells(R, 4).Value
                Department = Cells(R, 5).Value
                Sheets(Department).Select
                DRowCount = Cells(Cells.Rows.Count, 1).End(xlUp).Row
                Range("A" & DRowCount + 1).Select
                ActiveSheet.Paste
                Range("O" & DRowCount + 1).Value = RoutingStep
                Range("P" & DRowCount + 1).Value = Department

            End If
        Next
     Next
End Sub

Any Help will be Appreciated...

Posted 30-Jun-13 20:51pm

Raja Sekhar S

Updated 2-Jul-13 23:52pm

v4

Add a Solution

Comments

Maciej Los 1-Jul-13 12:50pm

Which version of MS Excel?
Do you really need to use macros?
What have you done so far?

Raja Sekhar S 2-Jul-13 0:32am

I am using Excel 2007...
Yes Macro is Compulsory...
i have added the code to the question....
I think by using Vlookup and concatenate we can reduce the time taken to execute the Macro.... Any Help..?

Raja Sekhar S 2-Jul-13 1:27am

i replaced one for loop with find function it's executing faster... still i think speed can be increased...

Thanks..!

Maciej Los 2-Jul-13 15:04pm

Please, do not post code in comment. Rather than posting code in comment, use "Improve question" widget.

Raja Sekhar S 3-Jul-13 0:54am

Will do that MaciejLos....

thanh_bkhn 3-Jul-13 3:32am

Sorry but I cannot understand your data name, data sheet, and its name in your code (InputData or DataInput, what is ProductRouting?...) Can you use Improve question and edit their name that I can understand how the correct result could be?

2 solutions

Add a Solution

Add your solution here

Treat my content as plain text, not as HTML

Preview 0

…

Existing Members

Sign in to your account

...or Join us

Download, Vote, Comment, Publish.

Your Email
Password
Forgot your password?

Your Email
This email is in use. Do you need your password?
Optional Password

I have read and agree to the Terms of Service and Privacy Policy
Please subscribe me to the CodeProject newsletters

When answering a question please:

Read the question carefully.
Understand that English isn't everyone's first language so be lenient of bad spelling and grammar.
If a question is poorly phrased then either ask for clarification, ignore it, or edit the question and fix the problem. Insults are not welcome.
Don't tell someone to read the manual. Chances are they have and don't get it. Provide an answer or move on to the next question.

Let's work to help developers, not make them feel stupid.

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

Fredrik Bornander · Accepted Answer · 2013-07-02T21:23:00

First of all, the input data doesn't seem to match your expected output data; you only have Item1s in the input data, and it only maps to ItemRoute1 so I can't see how you could get more than one Procurement and one Selling line from that input.

But, having said that, I think something like this might do the trick for you;

vba

Option Explicit

Sub FindMacro()

    Dim inputRow As Integer
    Dim procurementRow As Integer
    Dim sellingRow As Integer

    Dim inputDataSheet As Worksheet
    Dim itemRoutingSheet As Worksheet
    Dim routingSheet As Worksheet

    Set inputDataSheet = Sheets("DataInput")
    Set itemRoutingSheet = Sheets("ItemRouting")
    Set routingSheet = Sheets("Routing")

    procurementRow = 1
    sellingRow = 1

    For inputRow = 2 To 10
        Dim itemRoutingRow As Integer
        Dim inD As String
        Dim outD As String
        Dim item As String
        Dim unit As String
        Dim dateD As String
        Dim location As String

        inD = inputDataSheet.Cells(inputRow, 1)
        outD = inputDataSheet.Cells(inputRow, 2)
        item = inputDataSheet.Cells(inputRow, 3)
        unit = inputDataSheet.Cells(inputRow, 4)
        dateD = inputDataSheet.Cells(inputRow, 5)
        location = inputDataSheet.Cells(inputRow, 6)

        If Len(item) < 1 Then Exit For

        For itemRoutingRow = 2 To 10
            Dim routingItem As String
            routingItem = itemRoutingSheet.Cells(itemRoutingRow, 1)

            If Len(routingItem) < 1 Then Exit For

            If routingItem = item Then
                Dim routingRow As Integer
                Dim routing As String
                routing = itemRoutingSheet.Cells(itemRoutingRow, 2)

                For routingRow = 2 To 10
                    If routing = routingSheet.Cells(routingRow, 1) And inD = routingSheet.Cells(routingRow, 2) And outD = routingSheet.Cells(routingRow, 3) Then
                        Dim outputSheet As Worksheet
                        Dim department As String
                        Dim step As String

                        step = routingSheet.Cells(routingRow, 4)
                        department = routingSheet.Cells(routingRow, 5)
                        Set outputSheet = Sheets(department)

                        Dim row As Integer

                        If department = "Procurement" Then
                            procurementRow = procurementRow + 1
                            row = procurementRow
                        Else
                            sellingRow = sellingRow + 1
                            row = sellingRow
                        End If

                        outputSheet.Cells(row, 1) = inD
                        outputSheet.Cells(row, 2) = outD
                        outputSheet.Cells(row, 3) = item
                        outputSheet.Cells(row, 4) = unit
                        outputSheet.Cells(row, 5) = dateD
                        outputSheet.Cells(row, 6) = location
                        outputSheet.Cells(row, 7) = step
                        outputSheet.Cells(row, 8) = department

                    End If
                Next routingRow
                Exit For
            End If
        Next itemRoutingRow
    Next inputRow
End Sub

Hope this helps,
Fredrik

Maciej Los · Accepted Answer · 2013-07-03T00:08:00

The fastest way to achieve that is to use ADODB[^] with Dictionary[^] object.

More:
Using ADO with Excel Data Sources[^]
How To Use ADO.NET to Retrieve and Modify Records in an Excel Workbook With Visual Basic .NET[^]
Reading an Excel spreadsheet using ADO.NET[^]
How To Use the Dictionary Object with Visual Basic[^]
Using the Dictionary Class in VBA[^]

If i understand you well, you would like to export data into separate sheets based on Department name.

Example:

VB

Option Explicit
 
'exports data into separates sheets by Department
Sub SeparateData()
Dim wsh As Worksheet
Dim i As Long, j As Long
Dim sSQL As String, sTmp As String
Dim dict As Object, keyc As Variant, n As Variant
Dim adc As ADODB.Connection
Dim rst As ADODB.Recordset
Dim f As ADODB.Field

On Error GoTo Err_SeparateData

'create dictionary object to get DISTINCT departments
Set dict = CreateObject("Scripting.Dictionary")
Set wsh = ThisWorkbook.Worksheets("Routing")
j = 1
i = 2
Do While (wsh.Range("A" & i) <> "")
    sTmp = wsh.Range("E" & i)
    If Not dict.Exists(sTmp) Then dict.Add sTmp, j: j = j + 1
    i = i + 1
Loop

'open connection
Set adc = New ADODB.Connection
With adc
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 8.0;HDR=yes';"
    .CursorLocation = adUseClient
    .Open
End With

'go through the collection of dictionary keys
keyc = dict.Keys
For Each n In keyc
    'ignore error to add new sheet, if it doesn't exists
    On Error Resume Next
    Set wsh = ThisWorkbook.Worksheets(n)
    If Err <> 0 Or wsh Is Nothing Then
        Set wsh = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        wsh.Name = n
    End If
    'catch errors
    On Error GoTo Err_SeparateData
    
    'build SQL SELECT statement
    sSQL = "SELECT di.IN, di.Out, di.Item, di.Unit, di.Date, di.Location, ro.RoutingSteps AS RoutingStep, ro.Department" & vbCr & _
        "FROM ([DataInput$] AS di LEFT JOIN [ItemRouting$] AS ir ON di.Item = ir.Item) LEFT JOIN [Routing$] AS ro ON ro.Routing = ir.Routing" & vbCr & _
        "WHERE ro.Department = '" & n & "'"
    'MsgBox sSQL
    
    'open recordset
    Set rst = New ADODB.Recordset
    rst.Open sSQL, adc, adOpenStatic, adLockOptimistic
    'copy headers
    j = 0
    For Each f In rst.Fields
        wsh.Range("A1").Offset(0, j) = f.Name
        j = j + 1
    Next
    wsh.Range("1:1").Font.Bold = True
    'copy data
    wsh.Range("A2").CopyFromRecordset rst
    rst.Close
    Set rst = Nothing
Next

Exit_SeparateData:
    On Error Resume Next
    Set wsh = Nothing
    Set dict = Nothing
    Set f = Nothing
    rst.Close
    Set rst = Nothing
    adc.Close
    Set adc = Nothing
    Exit Sub
    
Err_SeparateData:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_SeparateData

End Sub


Function GetLastRow(wsh As Worksheet, Optional iColNo As Long = 1)

    GetLastRow = wsh.Cells(wsh.Rows.Count, iColNo).End(xlUp).Row

End Function

Can any one suggest how to write a macro for this...

2 solutions

Solution 1

Solution 2

Add your solution here

Preview 0