Excel VBA: Logic/Approach Suggestions? 3

[VBAjedi]

Hi all!

Any suggestions on the following problem I'm trying to solve would be greatly appreciated!

I have a spreadsheet with about 10,000 rows, each row representing 1 wall of a room (so there are four rows per room). Column "A" contains a room number (each room has a unique number). Column "B" contains a wall number (1-4). Column "C" contains the walls color (a text value).

I need to write some EFFICIENT VBA that, for each row, puts the color of one ADJACENT wall into Column "D", and the color of the other ADJACENT wall into Column "E".

My spreadsheet looks like this:

RoomID   WallID   WallColor   AdjWallColor   AdjWallColor
A241       1        Red
A241       2        Blue
A241       3        Green
A241       4        Yellow
B321       1        Orange
etc. . .

Any ideas on how I could go about this?

Thanks!
VBAjedi

 

[Zathras]

There may be more efficient ways, but here is one way:

Option Explicit

Sub ColorSideWalls()
Dim rngWork As Range
Dim c As Range
  Set rngWork = Intersect(Range("B1:B65536"), ActiveSheet.UsedRange)
  For Each c In rngWork
    If c.Value = 1 Then
      c.Offset(0, 2) = c.Offset(1, 1)
      c.Offset(0, 3) = c.Offset(3, 1)
    Else
      If c.Value = 4 Then
        c.Offset(0, 2) = c.Offset(-3, 1)
        c.Offset(0, 3) = c.Offset(-1, 1)
      Else
        c.Offset(0, 2) = c.Offset(1, 1)
        c.Offset(0, 3) = c.Offset(-1, 1)
      End If
    End If
  Next c
  Set rngWork = Nothing
End Sub

 

[RobBroekhuis]

Zathras' approach assumes you have the table sorted by room number, and that you have values (in order) for each of the walls. If your database is really that simple, I don't see why you even need a tool like this (copying a range of formulas down would achieve the same result). Is there something we're missing here?
Rob

 

[par60056]

Here is a simple script I would use.

Sub AdjacentWalls()
Dim rownum As Integer
Dim rowoff1 As Integer
Dim rowoff2 As Integer


'Assumes row 1 is headers and rooms start on 2
rownum = 2
While Not IsEmpty(Cells(rownum, 1))
If (Cells(rownum, 2) = 4) Then
rowoff1 = -3
Else
rowoff1 = 1
End If
If (Cells(rownum, 2) = 1) Then
rowoff2 = 3
Else
rowoff2 = -1
End If
' Validate that the room still matches
' Remove if you know the room data is all good
If (Cells(rownum, 1) <> Cells(rownum + rowoff1, 1) Or _
Cells(rownum, 1) <> Cells(rownum + rowoff2, 1)) Then
MsgBox &quot;Bad room number @ row &quot; + Format(rownum), vbOKOnly
End If
Cells(rownum, 4) = Cells(rownum + rowoff1, 3)
Cells(rownum, 5) = Cells(rownum + rowoff2, 3)

rownum = rownum + 1
Wend

End Sub


Peter Richardson

 

[VBAjedi]

Zathras,
Nice bit of code using Intersect in conjunction with ActiveSheet.UsedRange . I'll be using that - have a star!

However, I forgot (as I often do when describing an odd situation) a few key details.
As Rob suspected, I cannot assume that my data is sorted by RoomID. If I absolutely MUST, I will sort it at the beginning of my code, but I'd much prefer to leave it in the order it's in.
Also, I cannot assume that there will ALWAYS be four walls listed per room. I CAN set the maximum number of walls allowed per room(say, 6), but there may only be 2 or 3 listed in my database. I do know that wall 3 will always be adjacent to walls 2 and 4, etc.

In essence, for each row, my code must scan all the other rows, looking for a match on the RoomID. For any and all matches found, it must determine if the match is an adjacent wall, and, if so, write the matches color in columns &quot;D&quot; (or &quot;E&quot;, if &quot;D&quot; already contains a value).

My only idea so far was to apply an advanced filter to the list for each room ID, process the visible rows, then move on to the next room ID. But that sounds slow and I'm not sure I want to spend a heap of time trying to figure that out unless I think it's the most efficient method. As we always say here at Tek-Tips: &quot;There's GOT to be a better way!&quot;

Actual code is much appreciated, but even a description of an efficient methodology would be a big help.

Thanks, all!
VBAjedi

 

[Zathras]

So, if your room only has two walls, the result would look like this?

RoomID   WallID   WallColor   AdjWallColor   AdjWallColor
A241       1        Red         Orange         Orange
A242       2        Blue        Green          Yellow
A242       3        Green       Blue           Purple
A242       1        Yellow      Blue           Purple
A241       2        Orange      Red            Red
A242       4        Purple      Yellow         Green
etc. . .

I'm still trying to imagine a room with only two walls...

If you need to preserve the original sequence, then I would consider finding the first unused column and update with sequence numbers from 1 to 10,000. Then sort by room and wallID and update the adjacent wall colors. Finally sort by the sequence column and remove it.

A slight modification to my code would look ahead to see how many walls there are per room, then set variables for the first and last room offsets as well as the middle IF test. Shouldn't be too hard, really.

 

[RobBroekhuis]

Zathras is right - it will be MUCH faster to use Excel's built-in sorting capability than to handle the jumping-around otherwise required in VBA code.
Rob

 

[VBAjedi]

Zathras,

Ok, wiseguy! I'm not REALLY tracking room wall colors - that was just a simple example to illustrate my challenge. (But just for the record: a room with two walls has one straight wall and one U-shaped wall).

LOL

Joking aside, I will submit to the opinion of both you and Rob that using SORT will be fastest. I shouldn't have difficulty implementing that approach. I will post the modified (or mangled, depending. . . ) code back here.

Stars around!



VBAjedi

 

[VBAjedi]

Well, what I ended up doing is sorting as suggested. Then, for each row, I used Select Case SideNum (a.k.a. WallID) to determine the correct value of AdjSide1 and AdjSide2 keys, and scanned the four (MaxNumSides = 4) rows before and after the active row for the AdjSide1 and AdjSide2Keys. Still a bit bulky, but it runs through 5000 rows in sub-30 seconds, so I'm happy. My declarations and before/after sorting routines are stripped out. Here's the guts of it (wrapping is my usual mess) LOL :

' Loop through all SideKey rows and update AdjacentContent fields
  Set VehIDRange = Intersect(Range("B1:B65536"), SideData)
  For Each myCell In VehIDRange
    SideNum = myCell.Offset(0, 6).Value
    Select Case SideNum
    Case 1
        AdjSide1 = MaxNumSides
        AdjSide2 = SideNum + 1
    Case MaxNumSides
        AdjSide1 = SideNum - 1
        AdjSide2 = 1
    Case Else
        AdjSide1 = SideNum - 1
        AdjSide2 = SideNum + 1
    End Select
    
    For x = (0 - MaxNumSides) To MaxNumSides
        If ShSK.Cells((myCell.Row + x), myCell.Column).Value = myCell.Value Then ' VehID matches
            If ShSK.Range("H" & (x + myCell.Row)).Value = _
                AdjSide1 Then Range("P" & myCell.Row).Value = _
                ShSK.Range("M" & (x + myCell.Row)).Value
            If ShSK.Range("H" & (x + myCell.Row)).Value = _
                AdjSide2 Then Range("Q" & myCell.Row).Value = _
                ShSK.Range("M" & (x + myCell.Row)).Value
        End If
    Next x
  Next myCell

  Set VehIDRange = Nothing

Thanks for your help, Zathras and Rob!

VBAjedi

 

[combo]

Hi VBAjedi,
Just for exercise I used another approach to the problem.

Some description first:
1. I changed the code name for the sheet with input data (Name) is ShSource,
2. bolded 'Excel files' in definition of sCStr in DSN is my English translation (it is what you see in data source description when using external data),
3. this sub saves file as C:\wallsbook.xls first, and refers to it to get data and query it on added sheet,
4. the output data does not contain walls without defined two adjacent walls.

Here the code:

[tt]Sub TheWall()
Dim shOut As Worksheet
Dim qTab As QueryTable
Dim rTab As Range
Dim iTab(1 To 4, 1 To 2) As Integer
Dim iColor As Integer, i As Long, n As Long
Dim sWbk As String, sWbkShort As String
Dim sSQL As String
Dim sCStr As String

iTab(1, 1) = 4: iTab(1, 2) = 2
iTab(2, 1) = 1: iTab(2, 2) = 3
iTab(3, 1) = 2: iTab(3, 2) = 4
iTab(4, 1) = 3: iTab(4, 2) = 1

sWbk = &quot;C:\wallsbook.xls&quot;
sWbkShort = &quot;C:\wallsbook&quot;

sSQL = &quot;SELECT tData.RoomID, tData.WallID, tData.WallColor, tData_1.WallColor AS 'Wall1Color', tData_2.WallColor AS 'Wall2Color' FROM `&quot;
sSQL = sSQL & sWbkShort & &quot;`.tData tData, `&quot; & sWbkShort & &quot;`.tData tData_1, `&quot; & sWbkShort & &quot;`.tData tData_2 &quot;
sSQL = sSQL & &quot;WHERE tData.RoomID = tData_1.RoomID AND tData.RoomID = tData_2.RoomID AND tData.WallID = tData_1.Wall1ID AND tData.WallID = tData_2.Wall2ID&quot;
Set rTab = ShSource.Cells(1, 1).CurrentRegion
rTab.Name = &quot;tData&quot;
n = rTab.Rows.Count
With rTab
For i = 2 To n
iColor = .Cells(i, 2)
.Cells(i, 4) = iTab(iColor, 1)
.Cells(i, 5) = iTab(iColor, 2)
Next i
End With

ThisWorkbook.SaveAs Filename:=sWbk
Set shOut = ThisWorkbook.Worksheets.Add
sCStr = &quot;ODBC;DSN=Excel files;DBQ=&quot; & sWbk & &quot;;DefaultDir=C:;DriverId=790;MaxBufferSize=2048;PageTimeout=5;&quot;

Set qTab = shOut.QueryTables.Add(Connection:=sCStr, Destination:=shOut.Range(&quot;A1&quot, Sql:=sSQL)
With qTab
.CommandText = sSQL
.Name = &quot;Adjacent_Walls&quot;
.Refresh
End With
End Sub[/tt]

I am interested in the speed of this sub on your machine, so if you like to test it, please let me know.

combo

 

[combo]

Hi,
this should be a little faster code. Assumed that the workbook has one sheet with data (the best - only three first columns with headers:
RoomID WallID WallColor
Check also DSN name

[tt]Sub TheWall()
Dim shIn As Worksheet, shOut As Worksheet, shWallsID As Worksheet
Dim qTab As QueryTable
Dim rTab As Range
Dim iTab(1 To 4, 1 To 2) As Integer
Dim iColor As Integer, i As Long, n As Long
Dim sWbk As String, sWbkShort As String
Dim sSQL As String
Dim sCStr As String

Set shIn = ThisWorkbook.Worksheets(1)
Set rTab = ThisWorkbook.Worksheets(1).Cells(1, 1).CurrentRegion
rTab.Name = &quot;tData&quot;

Set shWallsID = ThisWorkbook.Worksheets.Add
With shWallsID
.Name = &quot;AdjWallsIDs&quot;
.Cells(1, 1) = &quot;WallID&quot;: .Cells(1, 2) = &quot;Wall1ID&quot;: .Cells(1, 3) = &quot;Wall12D&quot;
.Cells(2, 1) = 1: .Cells(2, 2) = 4: .Cells(2, 3) = 2
.Cells(3, 1) = 2: .Cells(3, 2) = 1: .Cells(3, 3) = 3
.Cells(4, 1) = 3: .Cells(4, 2) = 2: .Cells(4, 3) = 4
.Cells(5, 1) = 4: .Cells(5, 2) = 3: .Cells(5, 3) = 1
.Cells(1, 1).CurrentRegion.Name = &quot;tAdjWalls&quot;
End With

sWbk = &quot;C:\wallsbook.xls&quot;
sWbkShort = &quot;C:\wallsbook&quot;

ThisWorkbook.SaveAs Filename:=sWbk

sCStr = &quot;ODBC;DSN=Excel files;DBQ=&quot; & sWbk & &quot;;DefaultDir=C:;DriverId=790;MaxBufferSize=2048;PageTimeout=5;&quot;

sSQL = &quot;SELECT tData.RoomID, tData.WallID, tData.WallColor, tData_1.WallColor AS 'Wall1Color', tData_2.WallColor AS 'Wall2Color'FROM `&quot;
sSQL = sSQL & sWbkShort & &quot;`.tAdjWalls tAdjWalls, `&quot; & sWbkShort & &quot;`.tAdjWalls tAdjWalls_1, `&quot; & sWbkShort
sSQL = sSQL & &quot;`.tData tData, `&quot; & sWbkShort & &quot;`.tData tData_1, `&quot; & sWbkShort & &quot;`.tData tData_2 &quot;
sSQL = sSQL & &quot;WHERE tData.WallID = tAdjWalls.WallID AND tAdjWalls.Wall1ID = tData_1.WallID AND tData.RoomID = tData_1.RoomID AND &quot;
sSQL = sSQL & &quot;tData.WallID = tAdjWalls_1.WallID AND tAdjWalls_1.Wall12D = tData_2.WallID AND tData.RoomID = tData_2.RoomID&quot;

Set shOut = ThisWorkbook.Worksheets.Add
With shOut
.Name = &quot;Adjacent cells&quot;
Set qTab = .QueryTables.Add(Connection:=sCStr, Destination:=shOut.Range(&quot;A1&quot, Sql:=sSQL)
With qTab
.CommandText = sSQL
.Name = &quot;Adjacent_Walls&quot;
.Refresh
End With
End With

End Sub[/tt]

combo

 

[VBAjedi]

combo,

Your post definitely has my interest. I have been trying to figure out how to use SQL queries within Excel for a while now.

However, I am getting an error on the following line of code:

With qTab
.CommandText = sSQL

&quot;Run-time error 438 - object doesn't support this property or method&quot;.

I use Excel 97 - is .CommandText not a QueryTables option in 97?

Any help you can offer would be much appreciated - I'd REALLY like to learn how to do this!

Thanks,

VBAjedi

 

[VBAjedi]

Also, Combo, I should mention that I tried replacing &quot;.CommandText = sSQL&quot; with &quot;.Sql = sSQL&quot;, but then got a &quot;General ODBC Error&quot; on the &quot;.Refresh&quot; statement.

Autocomplete tells me that I have the following options for qTab:

Application, .BackgroundQuery, .CancelRefresh, .Connection, .Creator, .Delete, .Destination, .EnableEditing, .EnableRefresh, .FetchedRowOverflow, .FieldNames, .FillAdjacentFormulas, .HasAutoFormat, .Name, .Parameters, .Parent, .PostText, .RecordSet, .Refresh, .Refreshing, .RefreshOnFileOpen, .RefreshStyle, .ResultRange, .RowNumbers, .SaveData, .SavePassword, .Sql, .TablesOnlyFromHTML


Any ideas?
VBAjedi

 

[combo]

Hi VBAjedi,
your problem made me do start to play with external data with VBA. I did it in excel XP, so you miss some properties in xl97.
What I did is (something I put to code):
1. I named input data range (tData)
2. I added an intermediary worksheet (named AdjWallsIDs), here is a small table (headers + 4rows, with no. of wall, no. of first neighbour and no. of second neighbour). I named this table &quot;tAdjWalls&quot.
3. I saved the workbook (to have access to data), in the root directory (to shorten SQL string).
4. I added another worksheet and started to record macro. I choosed Data>External data>New querry. I linked to excel files and selected saved workbook. I used MS Query to get visual environment. I added Data table three times and twice intermediary walls ID table, and joined proper fields (I don't know if you can get data from multi-sheet workbook in xl97). I returned output data to excel and stopped recording.
5. I selected to string variables SQL and connection, the SQL string should be universal.

Hope you will be able do do something like this in excel 97, possibly with three workbooks instead of sheets in one workbook.

combo

 

[combo]

Back to the error you have, it can be caused by driver (in cCstr, which I simply copied from recorded macro, replacing only workbook path by variable sWbk).
Missing .CommandText - if you analyse a simple macro recorded, you will find where to place the string instead. Fortunatelly, earlier excels had better help.
In my case it was important to name tables with data, without it MS Query does not see any table to add.