VBA: Index match and re-inserting lines with multiple target values.

Hello Expert,

I use the following code to index match values from different sheets


Dim p As Integer, q As Integer

With ActiveSheet.Select

Range("F2", Range("F" & Rows.Count).End(xlUp)).Clear

Set Target = Range("sheet1!B2:C" & Rows.Count)
Set matchvalue = Range("C2", Range("C" & Rows.Count).End(xlUp))
Set comparedvalue = Range("sheet1!A2:A" & Rows.Count)

For Each c In matchvalue

If IsNumeric(Application.Match(c, comparedvalue, 0)) Then
c.Offset(, 1).Value = Application.WorksheetFunction.Index(Target, Application.WorksheetFunction.Match(c, comparedvalue, 0), 0)
End If
Next c
End With

Open in new window


However I would like to enhance this code to manage different Target values with different compared values

Ex:

Sheet1:

aaa,111
bbb,222
ccc,333
aaa,3455
ddd,444
aaa,456789

(aaa, contains more than one target value)
 

ActiveSheet

C1,C2,aaa,C3,C4
C1,C2,ddd,C3,C4
C3,C4,aaa,C3,C4
C1,C2,ccc,C3,C4
C1,C2,bbb,C3,C4
C1,C2,aaa,C3,C4
C1,C2,bbb,C3,C4
C1,C2,aaa,C3,C4
C1,C2,aaa,C3,C4
C1,C2,ccc,C3,C4

After I run the script some lines need to be re-inserting to display all the Target values with the same compared value
ActiveSheet
C1,C2,aaa,C3,C4,111
C1,C2,aaa,C3,C4,3455
C1,C2,aaa,C3,C4,456789
C1,C2,ddd,C3,C4,444
C3,C4,aaa,C3,C4,111
C3,C4,aaa,C4,3455
C3,C4,aaa,C4,456789
C1,C2,ccc,C3,C4,333
....

Could someone provide the VB Script or the VBA solution?
Thank you in advance for your help.
LVL 1
LD16Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

LD16Author Commented:
@Aikimark:

One question is related to VBA in which I provide my code to be enhanced.
The other question is related to VB Script in which I take as a reference another VB Script Code.
The two questions cannot be merged as they are related to different Programming languages and they use differents input codes.

Please don't delete the questions.

Thank you in advance.
0
LD16Author Commented:
If necessary I can change data example. The problem is similar however the solution of each problem will be completely different. One will be coded in Vba and the orher in VB script.  If necessary I can merge the question into one requesting the VBA and Vbscript approach.
0
LD16Author Commented:
Ok, If the best is to remove the other question, I remove the question.
0
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

LD16Author Commented:
Technically they are the same but I expect two approaches. VB Script approach and VBA Approach.
0
LD16Author Commented:
You can run in VB Script VBA with Excel Application however if I want to launch the script from a server with task scheduler it will not works if I don't have an opened windows session, I have already test it.

I want to have the two solutions as it can be useful for my general knowledge.

Regards,
0
LD16Author Commented:
I can with VB Script I cannot when I use VB Script with Excel.Application as it's required to have a office session available. You cannot open a Excel sheet if you don't have a session available this is why I want to have the pure VB Script approach without using Excel.Application and also the VBA approach.
0
aikimarkCommented:
What is your budget?
What are you allowed to install on the server?
Which Excel workbook formats will you be required to process?

It would probably be cheaper and simpler to install Excel on the server than to try to solve this with a third party or .Net solution.
0
LD16Author Commented:
I think there is a misunderstanding, I have excel in my server the thing is when I launch an Excel.Application script through task scheduler I need to be connected in the server  whereas if I launch a pure .vbs through task scheduler I can do it without having a windows session opened.
By the way could you please help me with the solution in VBA or in VB Script?
Thank you in advance for your help.
0
aikimarkCommented:
What privileges are you running with when the scheduled task fails?
What does your scheduled task look like when it fails?

I think you have finally revealed your actual problem/question in your latest comment.
0
LD16Author Commented:
Administrator highest privileges.

Please find attached the mentioned options.
Capture.GIF
It is not possible to run a VB Script which call a Excel.Application using the option "Run whether user is logged on or not". The unique way to run it is to select the option "Run only when user is logged on".

However for a pure VB Script which doesn't call  Excel Application I can select the second option which allows me to be logged off of the server.
0
aikimarkCommented:
what command are you executing in this task?
0
LD16Author Commented:
Simple command :

Option Explicit

Dim xlApp, xlBook

Set xlApp = CreateObject("Excel.Application")
'~~> Change Path here
Set xlBook = xlApp.Workbooks.Open("C:\Users\1\Import_cleaning_1.4.1.xlsm", 0, True)
xlApp.Run "run_csv_import"
xlBook.Close
xlApp.Quit

Open in new window


Can we focus on the first question I will create another question concerning the schedule task run if necessary.
0
aikimarkCommented:
I meant HOW are you launching the process in the scheduled task?
0
LD16Author Commented:
I just click on run, by the way it is a "schedule task" so it's run itself
0
aikimarkCommented:
Please bring up the properties dialog for that scheduled task and post the executable line and the working directory text.
0
LD16Author Commented:
Hello, the scheduled task is another problem I would like to have advices concerning my question: ID: 28655245
0
LD16Author Commented:
I don't understand your comment.

Firstrly you ask me to merge VB Script and VBA questions as they were the same. I followed your recommendation and I delete VB Script to keep VBA question.

Now that I want is to have a proposal concerning my question 2865524.
0
aikimarkCommented:
Now that I want is to have a proposal concerning my question 2865524.
http:Q_28655245.html is this question

I've asked you a question that you have not answered.  I'm actually trying to help you with your problem.  You must participate.
0
LD16Author Commented:
Ok. I have solved the schedule task problem.  I gave me full  admin access in the server.

Concerning question 228655245 I have not received a proposal.
0
aikimarkCommented:
did the rights change solve your problem?
0
LD16Author Commented:
Yes for the schedule task.
0
LD16Author Commented:
The problem related to the schedule task is solved, however I want expertise and an proposal related to question 28655245
0
aikimarkCommented:
What is the worksheet name that needs to be updated?
0
LD16Author Commented:
ActiveSheet = sheet 2
0
aikimarkCommented:
This code should be used in conjunction with your existing script.  You will need to add qualifiers to your open workbook and replace "Application" with the name of your Excel automation object variable.
    Dim dicKeys ' As Object
    Dim rng ' As Range
    Dim wks ' As Worksheet
    Dim vParsed ' As Variant
    Dim lngRow ' As Long
    Dim lngEnd ' As Long
    Dim lngNextValue ' As Long
    Dim vItem ' As Variant
    Dim strValue ' As String
    
    Set dicKeys = CreateObject("scripting.dictionary")
    Set wks = Worksheets("Sheet1")
    For Each rng In wks.Range(wks.Range("A1"), wks.Range("A1").End(xlDown))
        vParsed = Split(rng.Value, ",")
        If dicKeys.exists(vParsed(0)) Then
            dicKeys(vParsed(0)) = dicKeys(vParsed(0)) & "^" & vParsed(1)
        Else
            dicKeys(vParsed(0)) = vParsed(1)
        End If
    Next
    
    Set wks = Worksheets("Sheet2")
    lngEnd = wks.Range("A1").End(xlDown).Row
    Application.ScreenUpdating = False  'use Excel object here
    For lngRow = lngEnd To 1 Step -1
        vParsed = Split(wks.Cells(lngRow, 1).Value, ",")
        If dicKeys.exists(vParsed(2)) Then
            strValue = wks.Cells(lngRow, 1).Value
            wks.Rows(lngRow).Delete
            wks.Rows(lngRow).Resize(UBound(Split(dicKeys(vParsed(2)), "^")) + 1).Insert
            lngNextValue = lngRow
            For Each vItem In Split(dicKeys(vParsed(2)), "^")
                wks.Cells(lngNextValue, 1).Value = strValue & "," & vItem
                lngNextValue = lngNextValue + 1
            Next
        End If
    Next
    Application.ScreenUpdating = True   'use Excel object here

Open in new window

0
LD16Author Commented:
Hello aikimark,

Thank you for your code, I have some questions:

1-How should I run this code Can I run it directly through an Excel File by inserting it into a VBA Module or through an independent .vbs file?
2-If the first I need to enter a Sub and a End sub between your code?
3-When you say in "conjunction with my existing script" you refer to the code which is in the question ID: 28655245. I suppose that yes but I want to confirm.
4-I don't understand: "You will need to add qualifiers to your open workbook and replace "Application" with the name of your Excel automation object variable". It would be great if you can help me to add it this because I don't know how to do it.

Once again, thank you for your help!
0
aikimarkCommented:
You should be able to run this in either environment.
I tested this code in an Excel VBA environment, so it was the body of a sub routine in a workbook module.
The code does not open a workbook.  You already have VBScript code that does that.
0
LD16Author Commented:
Ok, thank you for your feedback, should I need to add something else to your code or can I directly test it like this?
0
aikimarkCommented:
If you have a workbook with the data in Sheet1 and Sheet2, you should be able to create a new routine, paste the code into the routine, and run the routine in its current state.

To run this as a VBScript, you will need to add the VBS code from your previous question and qualify some of the assignments (Set wks =) with your workbook variable.  Also, the "Application" object will need to be changed to your Excel automation object variable.
0
LD16Author Commented:
Perfect I test it and It works, however this suit for csv files when you have all the data compiled in one column.

However I just realized that the data of Sheet 1 and Sheet 2 is already is already splitted in multiple column:

The key in sheet 1will be placed in column C and the key in Sheet 2 is also in column C.

Additionnally it would be great if all the modifications are done in a Sheet 3 this will help me see the difference between the initial Sheet 2 and the revised version in Sheet 3 after I launch the script.

Thank  you again for your help.
0
aikimarkCommented:
That's what happens when you don't post a representative sample of the data.  Please post a workbook  or CSV with the data as it will be encountered by the code.
0
LD16Author Commented:
Sorry for this.
Please find attached sample file.
Key of Sheet1 Column A
Key of Sheet2 Column C

Regards,
index-match-multiple-insert.xlsm
0
aikimarkCommented:
Putting the results in a different worksheet actually simplifies the code
    Dim dicKeys ' As Object
    Dim rng ' As Range
    Dim wks ' As Worksheet
    Dim vItem ' As Variant
    Dim strValue ' As String
    Dim rngTgt ' As Range
    Dim wksTgt ' As Worksheet
    
    Set dicKeys = CreateObject("scripting.dictionary")
    Set wks = Worksheets("Sheet1")
    For Each rng In wks.Range(wks.Range("A2"), wks.Range("A2").End(xlDown))
        If dicKeys.exists(rng.Value) Then
            dicKeys(rng.Value) = dicKeys(rng.Value) & "^" & rng.Offset(0, 1).Value
        Else
            dicKeys(rng.Value) = rng.Offset(0, 1).Value
        End If
    Next
    
    Set wks = Worksheets("Sheet2")
    Set wksTgt = Worksheets("Sheet3")
    Set rngTgt = wksTgt.Range("A2")
    Application.ScreenUpdating = False  'use Excel object here
    For Each rng In wks.Range(wks.Range("A2"), wks.Range("A2").End(xlDown))
        If dicKeys.exists(rng.Offset(0, 2).Value) Then
            For Each vItem In Split(dicKeys(rng.Offset(0, 2).Value), "^")
                wksTgt.Range(rngTgt, rngTgt.Offset(0, 4)).Value = wks.Range(rng, rng.Offset(0, 4)).Value
                rngTgt.Offset(0, 5).Value = vItem
                Set rngTgt = rngTgt.Offset(1, 0)
            Next
        End If
    Next
    Application.ScreenUpdating = True   'use Excel object here

Open in new window

0
LD16Author Commented:
Perfect I will test it tomorrow.
0
LD16Author Commented:
Ok, I have test it and it works! Thank you again now the challenge is to convert this code into pure VB Script.

Here is the code provided in the solution:

 http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_26685812.html#a34385354:

' Define constants
Const cForReading = 1
Const cForWriting = 2
Const cForAppending = 8
Const cTristateTrue = -1
Const cTristateFalse = 0
Const cTristateUseDefault = -2

' Define filenames
Const cInFile1 = "C:\Temp\EE26685812\file1.csv"
Const cInFile2 = "C:\Temp\EE26685812\file2.csv"
Const cOutFile = "C:\Temp\EE26685812\file3.csv"

' Set up objects needed
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oDict = CreateObject("Scripting.Dictionary")
 
' Load dictionary entries from text file of replacements
Set oInFile1 = oFSO.OpenTextFile(cInFile1, cForReading)
Do Until oInFile1.AtEndOfStream
   aLine = Split(oInFile1.Readline, ",")
   If Not oDict.Exists(aLine(0)) Then
      oDict.Add aLine(0), aLine(1)
   End If
Loop
oInFile1.Close
 
' Read input file, lookup replacement, write new output line'
Set oInFile2 = oFSO.OpenTextFile(cInFile2, cForReading)
Set oOutFile = oFSO.OpenTextFile(cOutFile, cForWriting, True)
Do Until oInFile2.AtEndOfStream
   aLine = Split(oInFile2.Readline, ",")
   ReDim Preserve aLine(UBound(aLine)+1)
   aLine(5) = aLine(4)
   aLine(4) = aLine(3)
   If oDict.Exists(aLine(2)) Then
      aLine(3) = oDict.Item(aLine(2))
   Else
      aLine(3) = "N/A"
   End If
   oOutFile.WriteLine Join(aLine, ",")
Loop

' Done
oInFile2.Close
oOutFile.Close

Open in new window



I am not sure how can I adapt your code using pure VB Script variables based on this code. Thank you again for your help!
0
Bill PrewIT / Software Engineering ConsultantCommented:
@LD16,

This VBS should do what I think you are looking for, adjust and test.

' Define constants
Const cForReading = 1
Const cForWriting = 2
Const cForAppending = 8
Const cTristateTrue = -1
Const cTristateFalse = 0
Const cTristateUseDefault = -2

' Define filenames
Const cInFile1 = "B:\EE\EE28655245\file1.csv"
Const cInFile2 = "B:\EE\EE28655245\file2.csv"
Const cOutFile = "B:\EE\EE28655245\file3.csv"

' Set up objects needed
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oDict = CreateObject("Scripting.Dictionary")
 
' Load dictionary entries from text file of replacements
Set oInFile1 = oFSO.OpenTextFile(cInFile1, cForReading)
Do Until oInFile1.AtEndOfStream
   aLine = Split(oInFile1.Readline, ",")
   If oDict.Exists(aLine(0)) Then
      oDict.Item(aLine(0)) = oDict.Item(aLine(0)) & "," & aLine(1)
   Else
      oDict.Add aLine(0), aLine(1)
   End If
Loop
oInFile1.Close
 
' Read input file, lookup replacement, write new output line'
Set oInFile2 = oFSO.OpenTextFile(cInFile2, cForReading)
Set oOutFile = oFSO.OpenTextFile(cOutFile, cForWriting, True)
Do Until oInFile2.AtEndOfStream
   aLine = Split(oInFile2.Readline, ",")
   ReDim Preserve aLine(UBound(aLine)+1)
   aLine(5) = aLine(4)
   aLine(4) = aLine(3)
   If oDict.Exists(aLine(2)) Then
      aValues = Split(oDict.Item(aLine(2)), ",")
      For Each sValue In aValues
         aLine(3) = sValue
         oOutFile.WriteLine Join(aLine, ",")
      Next
   Else
      aLine(3) = "N/A"
      oOutFile.WriteLine Join(aLine, ",")
   End If
Loop

' Done
oInFile2.Close
oOutFile.Close

Open in new window

~bp
0
LD16Author Commented:
Hello Bill,

Thank you for your help. I have test it and it works!

I have just few remarks:

1- how can I properly add combine headers from file 1 and file 2

I Know that I can try something like this

oOutFile.WriteLine  "Field1" &  ";" & "Field2"

However I would like use  existing variable from the various files.

2-I was wondering how can I create a simple loop to wscript.quit when the file is s not available for writting as it is already opened by another user?

Thank you in advance for your help!
0
Bill PrewIT / Software Engineering ConsultantCommented:
So, do both file1 and file2 have a single first line as a header line?  And you want to merge those values to create a new header line to be written at the top of the output file?

When the output file is in use, you just want to exit?  You mentioned "loop" in there, but wasn't sure if that's what you meant.

~bp
0
LD16Author Commented:
I think it will clearer if I give you an example:

File 1 contains the following header:

CP;Code (Code is the header of the values which appear in file3)

File 2 contains the following header:

CC; Designation; FHM;CP

Header of Output file should contains:


CC; Designation; FHM;CP;Code

So CC, Designation, FHM are the headers of File 2 and Code header of File 1.

Sorry I made a mistake concerning the loop, I need an

 if objfile ..... then
wscript.quit
   objLogFile.WriteLine "ERROR - File cannot be modified"
0
Bill PrewIT / Software Engineering ConsultantCommented:
Okay, this should address those additional asks.

' Define constants
Const cForReading = 1
Const cForWriting = 2
Const cForAppending = 8
Const cTristateTrue = -1
Const cTristateFalse = 0
Const cTristateUseDefault = -2

' Define filenames
Const cInFile1 = "B:\EE\EE28655245\file1.csv"
Const cInFile2 = "B:\EE\EE28655245\file2.csv"
Const cOutFile = "B:\EE\EE28655245\file3.csv"

' Set up objects needed
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oDict = CreateObject("Scripting.Dictionary")

' Open output file first, to make sure it is writeable
On Error Resume Next
Set oOutFile = oFSO.OpenTextFile(cOutFile, cForWriting, True)
If Err.Number <> 0 Then 
   ShowError "Error opening output file.", "Filename = " & cOutFile
   Wscript.Quit
End If
On Error Goto 0
 
' Load dictionary entries from text file of replacements
Set oInFile1 = oFSO.OpenTextFile(cInFile1, cForReading)
iLine = 0
strHeader = ""
Do Until oInFile1.AtEndOfStream
   iLine = iLine + 1
   aLine = Split(oInFile1.Readline, ",")
   ' Grab header line from first record, get second value for merged header
   If iLine = 1 Then
      strHeader = aLine(1)
   Else
      ' Add this mapping to the dictionary (new, or extend existing entry)
      If oDict.Exists(aLine(0)) Then
         oDict.Item(aLine(0)) = oDict.Item(aLine(0)) & "," & aLine(1)
      Else
         oDict.Add aLine(0), aLine(1)
      End If
   End If
Loop
oInFile1.Close
 
' Read input file, lookup replacement, write new output line'
Set oInFile2 = oFSO.OpenTextFile(cInFile2, cForReading)
iLine = 0
Do Until oInFile2.AtEndOfStream
   iLine = iLine + 1
   aLine = Split(oInFile2.Readline, ",")
   ' If first line of file, build merged header and write to output file
   If iLine = 1 Then
      strHeader = Join(aLine, ",") & "," & strHeader
      oOutFile.WriteLine strHeader
   Else
      ' Lookup mapping and add additional values and records
      ReDim Preserve aLine(UBound(aLine)+1)
      aLine(5) = aLine(4)
      aLine(4) = aLine(3)
      If oDict.Exists(aLine(2)) Then
         aValues = Split(oDict.Item(aLine(2)), ",")
         For Each sValue In aValues
            aLine(3) = sValue
            oOutFile.WriteLine Join(aLine, ",")
         Next
      Else
         aLine(3) = "N/A"
         oOutFile.WriteLine Join(aLine, ",")
      End If
   End If
Loop

' Done
oInFile2.Close
oOutFile.Close

Sub ShowError(strLocation, strMessage)
   WScript.StdErr.WriteLine "==> ERROR at [" & strLocation & "]"
   WScript.StdErr.WriteLine "    Number:[" & Err.Number & "], Source:[" & Err.Source & "], Desc:[" &  Err.Description & "]"
   WScript.StdErr.WriteLine "    " & strMessage
   Err.Clear
End Sub

Open in new window

~bp
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
LD16Author Commented:
I test it and it works, excellent as always! thank you again Bill!
I didn't now about this ShowError sub. I am sure that I will re-use it!
0
Bill PrewIT / Software Engineering ConsultantCommented:
Welcome, glad that was useful.

~bp
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.