Ranges

[waqas]

I have below ranges. Its randomly increased or decreased each range have its own color and value. There's merge also. If i use union it merge all together i have to merge max two two cells if it is in range. What i have to do if i click all ranges should select at once changed color put the value in all cells. I am using loops but it take time.

Range("AI77:AJ77,AI78:AJ78,AI79:AJ79,AI80:AJ80,AI81:AJ81,AI82:AJ82,AI83:AJ8 3,AI84:AJ84,AI85:AJ85,AI86:AJ86,AI87:AJ87,AI88:AJ88,AK86:AL86,AN35:AO35,AN3 6:AO36"), _

Range("AN43:AO43,AP50,AQ112:AR112,AQ113:AR113,AT103:AU103,AT104:AU104,AT105 :AU105,AT106:AU106,AW76:AX76,AW77:AX77,AW78:AX78,AW79:AX79,AW80:AX80,AY34,A Y40"), _

Range("AY42,AY43,BL49:BM49,BR58:BS58,BR59:BS59,BR66:BS66,BR67:BS67,BT36:BU3 6,CF47:CG47,CF48:CG48,CF51:CG51,CF55:CG55,CH52:CI52,CH53:CI53,CH54:CI54"), _

Range("CL36,CR60,CR61,CZ53:DA53,DA34:DB34,DA35:DB35,DA36:DB36,DA37:DB37,DA3 8:DB38,DM34:DN34,DO40:DP40,DS51:DT51,DW46,DX59:DY59,DX61:DY61"), _

Range("DX62:DY62,DY34,DY36,DY37,DY40,DY42,DY51:DZ51,DY54:DZ54,DZ35,DZ36,EA3 4:EB34,EA38:EB38,EA41:EB41,EA43:EB43,EA51:EB51"), _

Range("EA65,EB63:EC63,EB64:EC64,EC39,EC40,EE42:EF42,EE51:EF51,EG34,EG60,EI3 4:EJ34,EI36:EJ36,EI37:EJ37,EI39:EJ39,EI40:EJ40,EI42:EJ42"), _

Range("EI53:EJ53,EL105:EM105,EL106:EM106,EL107:EM107,EL108:EM108,EM38:EN38, EN108:EO108,EN109:EO109,EN110:EO110,EN111:EO111,EN112:EO112,EN113:EO113,EN1 14:EO114,EN115:EO115,EN116:EO116 "), _

Range("EN62:EO62,EN63:EO63,EQ35:ER35,EQ39:ER39,EQ46:ER46,EQ47:ER47,EQ48:ER4 8,EQ49:ER49,EQ50:ER50,EQ51:ER51,ER58:ES58,ER92,ES123:ET123,ES124,ES52:ET52" ), _

Range("ES53:ET53,ES79,ES80,ES81,ES82,ES83,ES84,ES85,ET125,ET62:EU62,EU124:E V124,EV61:EW61,EY38:EZ38,EZ89,EZ90"), _

Range("EZ91,FB64:FC64,FB65:FC65,FB66:FC66,FB79:FC79,FB80:FC80,FB81:FC81,FB8 2:FC82,FB83:FC83,FB84:FC84,FB85:FC85,FB86:FC86,FB87:FC87,FB88:FC88,FB89:FC8 9"), _

Range("FB90:FC90,FB91:FC91,FD62,FE34,FE41,FF58:FG58,FF59:FG59,FG41,FG43,FH1 02:FI102,FH103:FI103,FH104:FI104,FH105:FI105,FH106:FI106,FH80:FI80"), _

Range("FH81:FI81,FJ59,FJ63,FJ64,FJ65,FU30,FX23:FY23,FY16,FY17,FY19,GA37,GB1 2:GC12,GB13:GC13,GB16:GC16,GB24:GC24"), _

Range("GB58:GC58,GB64:GC64,GB66:GC66,GB67:GC67,GD17,GD34:GE34,GD40:GE40,GD4 3:GE43,GD62:GE62,GD63:GE63,GE29,GF35,GF36,GF37,GG30:GH30"), _

Range("GG41,GG42,GH10:GI10,GI50:GJ50,GI51:GJ51,GL13:GM13,GL14:GM14,GL43:GM4 3,GM31:GN31,GN36:GO36,GN39:GO39,GN40:GO40,GO25,GO31,GP34:GQ34"), _

Range("GP59:GQ59,GP64:GQ64,GQ14:GR14,GS16:GT16,GS61,GS66,GS67,GT51,GV42:GW4 2,GV43:GW43,GV46:GW46,GV49:GW49,GW22,GX52:GY52,GX55:GY55"), _

Range("GX59:GY59,GX61:GY61,GZ52,HB35:HC35,HB37:HC37,HB40:HC40,HB41:HC41,HB4 6:HC46,HB47:HC47,HB67:HC67,HD52:HE52,HE23:HF23,HF40:HG40,HF46:HG46,HF58:HG5 8"), _

Range("HG15,HG18,HG26:HH26,HH54,HH61:HI61,HH63:HI63,HH64:HI64,HH65:HI65,HH6 7:HI67,HI47,HI50,HT15:HU15,HW17,HW18,HX40"), _

Range("HY29:HZ29,HY30:HZ30,IC38:ID38,IC39:ID39,IC40:ID40,ID10,IE29:IF29,IE3 0:IF30,IE31:IF31,IE41:IF41,IF54:IG54,IH55:II55,IK22:IL22,IK46,IK47"), _

Range("IK48,IL49,IL50,IM28,IN36,IN37,IN40,IN41,IO23:IP23,IO28:IP28,IO29:IP2 9,IO30:IP30,IP40,IP41,IP42"), _

Range("IP43,IQ10,IQ11,IQ12,IQ13,IQ14,IQ36:IR36,IQ37:IR37,IR49:IS49,IR53:IS5 3,IR54:IS54,IS17:IT17,IS22,IT58:IU58,IU10:IV10"), _

Range("IU11:IV11,IU12:IV12,IU13:IV13,IU16:IV16,IU17:IV17,IU18:IV18,IU19:IV1 9,IU51,IV53:IW53,IW58,IY31:IZ31,IZ50:JA50,IZ53:JA53,J37:K37,J38:K38"), _

Range("J39:K39,J40:K40,JA12:JB12,JA30:JB30,JB60:JC60,JC10:JD10,JC11:JD11,JC 43,JD22,JD23,JD24,JD25,JD26,JD52:JE52,JD55:JE55"), _

Range("JD59:JE59,JF13,JF14,JF60,JF61,JH64:JI64,JI25:JJ25,JI26:JJ26,JI43:JJ4 3,JJ17,JK18:JL18,JL34,JL35,JL36,JL37"), _

Range("JL40,JL49:JM49,JM11,JM12,JN18,JN48,JN50,JO34,U106:V106,U107:V107,U10 8:V108,Z40:AA40,Z41:AA41,Z42:AA42,Z43:AA43")).Select

[SamT]

You have a problem.

[waqas]

You have a problem.

I have draw yard in excel where i put boxes with two sizes 20 and 40 feet. Single cell for 20 two cells for 40. These boxes are currently 12000. On different location. These references i am using to show box location. To select location i have to use ranges which can be one or in thousand. Now tell me how can i select these ranges.

[SamT]

wagas,

I am sorry, did not mean to offend. You may call me Sam if you wish.

It sounds like you are at a shipping container yard. That is an interesting problem.

At this time, I think we need a Container Object or a Yard_Location Object, and maybe both Objects.

Tell me more about the business operation. About how it works. Why you have to select all those ranges at once. We here at the forum need to know some thing about the entire situation before we can try to find a solution.

SamT
As to your current question.

If you have permanent ranges you must use in code and if they are quite large, one method is to Select them on the sheet, then Name them with the Insert Menu >> Name >> Define Dialog. A (better?) alternative is to use a Helper Sheet with a list of names in one column and the addresses of the respective Ranges in the next column. There is a character count limit. IIRC, of 256 to the "value" of named Ranges. A cell has a character count limit of, IIRC, 32K, The same as a Code Module.

This little sub will let you put the addresses of any selected cells into a location so you can copy it into your code, or make the list mentioned.

Sub Get_Addresses()
  Sheets("Sheet3").Range("B2") = Selection.Address
End Sub

To use it, hold down the Ctrl Key and Select all the Ranges you want the collective address for, then run the sub.

[Paul_Hossler]

To select location i have to use ranges which can be one or in thousand. Now tell me how can i select these ranges.

Please explain why it is necessary to select ALL cells containing a box. Is it to count them or something?

[waqas]

Please explain why it is necessary to select ALL cells containing a box. Is it to count them or something?

Dear Paul,
You can see in ranges there are single and two cells i have to change colors as per box colors and to put count of boxes in one place. In one location can be 1 or 5 boxes.

[Paul_Hossler]

Can you attach a small example showing the various boxes and colors and counts and etc.

I was thinking that it might be possible to avoid selecting everything at once and just loop through the cells. For example if every cell(s) of interest has a fill, a macro could use that to do other processing

You can see in ranges there are single and two cells i have to change colors as per box colors and to put count of boxes in one place. In one location can be 1 or 5 boxes.

I can see the one or two cell ranges, but I'm not understanding the 'change color per box color' and where the 'count of boxes' goes. Does it go into each cell or in a master total on a different sheet?

[waqas]

Can you attach a small example showing the various boxes and colors and counts and etc.

I was thinking that it might be possible to avoid selecting everything at once and just loop through the cells. For example if every cell(s) of interest has a fill, a macro could use that to do other processing

This is 10 mb file size


I can see the one or two cell ranges, but I'm not understanding the 'change color per box color' and where the 'count of boxes' goes. Does it go into each cell or in a master total on a different sheet?

[waqas]

i am sending picture of my file and some code i am doing every thing through loop. it takes time approx 1 to 2 minute.
just i want to reduce the time with selection the ranges at once and changing the color.

when i started this project it takes time to complete same task 10 to 15 minute now it reduced only 1 to 2 minutes.

now i want to do when user select any option result should come with in seconds.



Yard.jpg

Sub X() 'Name Unknown, SamT
Dim Conn As New ADODB.Connection, StrSql As String
Dim rs As New ADODB.Recordset, rscn As New ADODB.Recordset, RSMix As New ADODB.Recordset
Dim DBpath As String, sconnect As String, TRec As Integer, ContCategory As String, DatStr As Variant
Dim StackRs As New ADODB.Recordset, StkSql As String, CelRng As Range, Qty As Integer, rng As Variant, IMx As Integer
Dim BlkBR As String, OutRt As String
Option Base 1
Sub MixedCnt()
'** if i declare it glogely it bring previously value
Dim TxtRotSer As String
Application.ScreenUpdating = False
 
 Sheets("FilterData").Activate
    Columns("A:A").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
        
Sheets("Data").Activate
    Rows("1:1").Select
    Selection.Copy
    Sheets("FilterData").Select
    Rows("1:1").Select
    ActiveSheet.Paste
    Range("A1").Select


Call ClearBlk


Sheets("RotColor").Range("A1:A30").ClearContents


'FrmYard.LstRot.Selected(Item) = True
For i = 0 To FrmYard.LstRot.ListCount - 1


If FrmYard.LstRot.Selected(i) Then
AB = AB + 1
Sheets("RotColor").Range("A" & AB).Value = FrmYard.LstRot.List(i)
TxtRotSer = TxtRotSer & ",'" & FrmYard.LstRot.List(i) & "'"


End If
Next


If TxtRotSer = "" Then
Exit Sub
Else
TxtRotSer = Right(TxtRotSer, Len(TxtRotSer) - 1)
End If

       If FrmYard.OPTRot = True Then
        
            StrSql = "Select * from  [DATA$A1:BN65000] WHERE len(BlockBayRow) > 3 and OutRotation in (" & TxtRotSer & ");"
        ConnDbase
    ElseIf FrmYard.OptServ = True Then
        StrSql = "Select * from  [DATA$A1:BN65000] WHERE len(BlockBayRow) > 3 and Vservice in (" & TxtRotSer & ");"
        ConnDbase
    End If
'ElseIf FrmYard.OptFLYard = True Then
    'StrSql = "Select * from  [DATA$A1:BN65000] WHERE AddedLoc <>'-' ;"
'End If
End Sub

Sub ConnDbase()
DBpath = ThisWorkbook.FullName
    
    
        sconnect = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & DBpath & _
                ";Extended Properties=""Excel 12.0 XML; mACRO; HDR=Yes;"""


Conn.Open sconnect
rs.CursorLocation = adUseClient
rs.Open StrSql, Conn, adOpenStatic, adLockReadOnly




        '*********** Make String
        For Ary = 1 To rs.RecordCount
        
        RecCnt = RecCnt + 1
        Rcnt = RecCnt & " / " & rs.RecordCount
             DatStr = DatStr & ",'" & rs.Fields(10) & "'"
             rs.MoveNext
             FrmYard.LblCnt.Caption = Rcnt
             FrmYard.Repaint
        Next Ary
      If rs.RecordCount = 0 Then
      MsgBox "No Record Found"
            GoTo AB
       End If
       '**** Trim comma to make query accurate
        DatStr = Right(DatStr, Len(DatStr) - 2)
        DatStr = Left(DatStr, Len(DatStr) - 1)
        
        
        
'mixsql = "Select * from  [DATA$A1:BN65000] WHERE Vservice in (" & TxtRotSer & ") and BlockBayRow in ('" & DatStr & "' );"
'**** this query is to capture other service or rotation mixed in one row
mixsql = "Select * from  [DATA$A1:BN65000] WHERE BlockBayRow in ('" & DatStr & "' );"


RSMix.CursorLocation = adUseClient
RSMix.Open mixsql, Conn, adOpenDynamic, adLockOptimistic
RSMix.Sort = "[OutRotation]"


TRec = RSMix.RecordCount
Sheets("FilterData").Activate
Sheets("FilterData").Range("b1000000").End(xlUp).Select
Sheets("FilterData").Range("a1000000").End(xlUp).Offset(1, 0).CopyFromRecordset RSMix


DatStr = ""
'*****************************************
StkSql = "Select distinct BlockBayRow from  [FilterData$A1:BN65000]"
StackRs.CursorLocation = adUseClient
StackRs.Open StkSql, Conn, adOpenDynamic, adLockReadOnly
Sheets(1).Activate
GroundSlot = StackRs.RecordCount
        Do Until StackRs.EOF
            'dtsql = "Select count(*) from [FilterData$A1:BN65000] where BlockBayRow ='" & StackRs.Fields(0).Value & "'"
            BlkBR = StackRs.Fields(0).Value
            Call StackMix
            'Sheets("Blk").Range("a1000000").End(xlUp).Offset(1, 0).CopyFromRecordset StackRs1
            StackRs.MoveNext
        Loop

StackRs.Close
Set StackRs = Nothing
    rs.Close
    RSMix.Close
Conn.Close
AB:
    Set rs = Nothing
    Set RSMix = Nothing
    Set Conn = Nothing
DatStr = ""
Application.ScreenUpdating = True

End Sub

[Paul_Hossler]

1. SamT - thanks

2. wagas - can you extract just the code that loops and add colors? It's make it a lot easier to look at the slow portion. I searched for .Interior to see where the color loop was but .Interior was not there

[SamT]

I wonder if useing VBA to set Conditional formatting would work. Set the Conditions) to his "selection"_(sic)

[Paul_Hossler]

I wonder if useing VBA to set Conditional formatting would work. Set the Conditions) to his "selection"_(sic)

I'm still struggling with why the entire group of cells needs to be selected at once in order to apply what I believe is just a .Interior.ColorIndex = something

[SamT]

I am pretty sure that it is a container yard
and he is trying to show the locations there in.

[Paul_Hossler]

Yes, but why not container-by-container?

Why does it have to be all containers at once?

[SamT]

If it was me, I would write a ShippingContainer Class with all the Properties needed, including the Location. I would also have a YardMap Class to translate those locations into Ranges.

That would make it soooo easy to write a program for.

Where is Container #156195602

WhereIs = ShippingContainers("156195602").Location

Show me on the Excel Map

YardMap.Range(ShippingContainers("156195602").Location)).Color = Red

Show me all the Merck Line Containers

Dim Ctnr As ShippingContainer
For Each Ctnr in ShippingContainers
If Ctnr.Owner = "Merck Lines" Then _
YardMap.Range(ShippingContainers(Ctnr).Location)).Color = Red
Next Ctnr

Store all the data in a Flat Data Base like a CSV file and use snb's fantastic little one liners when coding.

Waqas wants speed. How about less than a second for anything.