is this .find query practically possible?

shanep

New Member
Joined
Mar 18, 2009
Messages
32
Hi

I have an Excel VBA problem and I need to know whether a solution is practically possible, so would really appreciate you're help.



I have a worksheet that contains two columns:
  1. a unique list of hostnames
  2. a list of applications assocaited with each hostname
e.g.
column A (hostnames) | Column B (Applications)

host1 | 00001 - App1; 00002 - App2
host2 | 00002 - App2; 03 - App3
host3 | 345 - App345; 3939 - App768 FedEx; 9876 - App243
host4 | 00001 - App1

As you can see there can be either a 1-1 relationship between host and App OR a 1-n relationship between host or App.

As you can also see, the AppID can be of varying length, as can the App Name (however, and importanty I think, where there is a 1-n relationship the Apps are always separated by a semicolon ";", and separated from the App Name by a dash "-")



I need to search through each hostname in my worksheet:
  1. Where there is a 1-1 relationship I need to add that hostname and AppID (NOTE - NOT THE Application Name) to a new worksheet (Column A for the hostname, column B for the Application ID.
  2. Where there is a 1-n relationship I need put a row in the new worksheet for each Application ID.
So, using my table above as an example, the new worksheet would contain the following rows:

column A (hostnames) | Column B (Applications)

host1 | 00001
host1 | 00002
host2 | 00002
host2 | 03
host3 | 345
host3 | 3939
host3 | 9876
host4 | 00001

Perhaps someone kind enough would be able to post the script to achieve this???

P.S. I could use this in a hurry... :):):)

Thanks in advance
Shane
 

Some videos you may like

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

al_b_cnu

Well-known Member
Joined
Jul 18, 2003
Messages
4,494
Code:
Option Explicit

Sub ExtractHosts()
Dim iptr As Integer
Dim lRowEnd As Long, lTarget As Long
Dim rCur As Range
Dim sApps As String
Dim saApps() As String
Dim vData(1 To 1, 1 To 2) As Variant
Dim wsFr As Worksheet, wsTo As Worksheet

Set wsFr = Sheets("Sheet1")
Set wsTo = Sheets("Sheet2")
lTarget = 0
lRowEnd = wsFr.Cells(Rows.Count, "A").End(xlUp).Row

For Each rCur In wsFr.Range("A1:A" & lRowEnd)
    vData(1, 1) = rCur.Value
    sApps = Trim$(CStr(rCur.Offset(, 1).Value))
    If sApps <> "" Then
        saApps = Split(sApps, ";")
        For iptr = 0 To UBound(saApps)
            vData(1, 2) = Val(saApps(iptr))
            lTarget = lTarget + 1
            wsTo.Range("A" & lTarget & ":B" & lTarget).Value = vData
        Next iptr
    End If
Next rCur
End Sub
 

davc4

New Member
Joined
Jan 8, 2009
Messages
16
seeing as you wanted this quickly i didn't tidy it up but here is a soloution to your question

Code:
Const DATA_SHEET = "Data"
Const RESULTS_SHEET = "Result"
Sub TrasnformData()
    Dim aInputArray As Variant
    Dim sOutputArray(100, 100) As String
    Dim sHost As String
    Dim nCount As Integer, nCount2 As Integer, ncount3 As Integer
    
    Dim rOutputArray As Range
    
    Dim r As Range
    Dim c As Range
    
    
    Set r = Worksheets(DATA_SHEET).UsedRange.Columns(1)
    If Not r Is Nothing Then
        For Each c In r.Cells
            If c.Row <> 1 Then
            
                sHost = c.Value
                aInputArray = c.Offset(0, 1).Value
                aInputArray = Split(aInputArray, ";")
            
                For nCount = LBound(aInputArray) To UBound(aInputArray)
                    aInputArray(nCount) = Left(aInputArray(nCount), InStr(1, aInputArray(nCount), " -"))
                Next nCount
                
                'fill SOutputArray
                For nCount = 0 To 100
                    If sOutputArray(nCount, 0) = sHost Then
                        Exit For
                    ElseIf sOutputArray(nCount, 0) = "" Then
                        sOutputArray(nCount, 0) = sHost
                        Exit For
                    End If
                Next nCount
                
                For nCount2 = LBound(aInputArray) To UBound(aInputArray)
                    For ncount3 = 0 To 100
                        If aInputArray(nCount2) = sOutputArray(nCount, ncount3) Then
                            Exit For
                        ElseIf sOutputArray(nCount, ncount3) = "" Then
                            sOutputArray(nCount, ncount3) = aInputArray(nCount2)
                            Exit For
                        End If
                    Next ncount3
                Next nCount2
            End If
        Next c
    End If
    
    
    Worksheets(RESULTS_SHEET).Activate
    Cells.ClearContents
    
    Cells(1, 1) = "Host"
    Cells(1, 2) = "Applications"
    
    Set rOutputArray = Range("A2")
    
    
    For nCount = 0 To 100
        If sOutputArray(nCount, 0) = "" Then Exit For
        For nCount2 = 1 To 100
            If sOutputArray(nCount, nCount2) = "" Then
                Exit For
            Else
                rOutputArray.Value = sOutputArray(nCount, 0)
                rOutputArray.Offset(0, 1).Value = CStr("'" & sOutputArray(nCount, nCount2))
                Set rOutputArray = rOutputArray.Offset(1, 0)
            End If
        Next nCount2
        
    Next nCount
End Sub
 

shanep

New Member
Joined
Mar 18, 2009
Messages
32
wow, thanks Guys, that was quick.........

al_b_cnu, I've gone with your as the code is shorter, but one question if you don't mind...

where an Application ID is listed as "00001" your script is displaying it as "1" in the new worksheet. Also, where an Application ID is listed as "44444444444" it is displaying as "4.444E+10".

I need to use these App ID's in the new worksheet to compare against App ID's in a different worksheet. Is there a way to retain the format of the App ID, i.e. "00001" instead of "1"

thanks
Shane
 

davc4

New Member
Joined
Jan 8, 2009
Messages
16

ADVERTISEMENT

Yup his is tidier they do the same thing i just fill the array before writing it out etc.

I can answer your question if you cstr() your output then excel should keep it as a text field rather than trying to convert it to a number.
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
47,926
Office Version
  1. 365
Platform
  1. Windows
I know I'm a bit late on the scene, but since I've written this I might as well post it. My assumptions are:

1. Original data is on a sheet called "Original", In columns A:B, starting in row 1.

2. Results are to go in a sheet called "Final" that is to be created (or re-created) as part of the process.

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Rearrange()<br>    <SPAN style="color:#00007F">Dim</SPAN> myData(), Apps<br>    <SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, j <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, nr <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> myApp <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    Application.DisplayAlerts = <SPAN style="color:#00007F">False</SPAN><br>    <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br>    Sheets("Final").Delete<br>    <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">GoTo</SPAN> 0<br>    Application.DisplayAlerts = <SPAN style="color:#00007F">True</SPAN><br>    <br>    <SPAN style="color:#00007F">With</SPAN> Sheets("Original")<br>        myData = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    Sheets.Add(After:=Sheets("Original")).Name = "Final"<br>    <SPAN style="color:#00007F">With</SPAN> Sheets("Final")<br>        nr = 2<br>        .Range("A1:B1").Value = Sheets("Original").Range("A1:B1").Value<br>        <SPAN style="color:#00007F">For</SPAN> i = 1 <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(myData, 1)<br>            Apps = Split(myData(i, 2), ";")<br>            <SPAN style="color:#00007F">For</SPAN> j = 0 <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(Apps)<br>                Cells(nr, 1).Value = myData(i, 1)<br>                myApp = Trim(Apps(j))<br>                myApp = Left(myApp, InStr(myApp, " ") - 1)<br>                <SPAN style="color:#00007F">With</SPAN> Cells(nr, 2)<br>                    .NumberFormat = "@"<br>                    .Value = myApp<br>                <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>                nr = nr + 1<br>            <SPAN style="color:#00007F">Next</SPAN> j<br>        <SPAN style="color:#00007F">Next</SPAN> i<br>        .Columns("A:B").AutoFit<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br>End <SPAN style="color:#00007F">Sub</SPAN><br></FONT>
 

al_b_cnu

Well-known Member
Joined
Jul 18, 2003
Messages
4,494
Code:
Option Explicit

Sub ExtractHosts()
Dim iPtr As Integer, iFind As Integer
Dim lRowEnd As Long, lTarget As Long
Dim rCur As Range
Dim sApps As String, sData As String
Dim saApps() As String
Dim vData(1 To 1, 1 To 2) As Variant
Dim wsFr As Worksheet, wsTo As Worksheet

Set wsFr = Sheets("Sheet1")
Set wsTo = Sheets("Sheet2")
lTarget = 0
lRowEnd = wsFr.Cells(Rows.Count, "A").End(xlUp).Row

For Each rCur In wsFr.Range("A1:A" & lRowEnd)
    vData(1, 1) = rCur.Value
    sApps = Trim$(CStr(rCur.Offset(, 1).Value))
    If sApps <> "" Then
        saApps = Split(sApps, ";")
        For iPtr = 0 To UBound(saApps)
            sData = Trim$(saApps(iPtr))
            iFind = InStr(sData, "-")
            If iFind <> 0 Then
                sData = "'" & Left$(sData, iFind - 1)
            End If
            vData(1, 2) = sData
            lTarget = lTarget + 1
            wsTo.Range("A" & lTarget & ":B" & lTarget).Value = vData
        Next iPtr
    End If
Next rCur
End Sub
 

shanep

New Member
Joined
Mar 18, 2009
Messages
32
thanks everyone!

For anyone who might need the same I went with al_b_cnu's last script which works exactly as required. :biggrin:

Cheers
Shane
 

Watch MrExcel Video

Forum statistics

Threads
1,122,491
Messages
5,596,466
Members
414,069
Latest member
StudExcel

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top