is this .find query practically possible?

[shanep]

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

 

[al_b_cnu]

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]

seeing as you wanted this quickly i didn't tidy it up but here is a soloution to your question

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]

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]

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]

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]

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]

thanks everyone!

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

Cheers
Shane