LRIS = Range Not quite working properly 1

[APElliott]

Hello,

I think Geoff (xlbo) wrote this code for me a while back and it works very well.

But.....

I,ve changed things slightly and needs some help!

In column U I have values say 01 to 40. Before I run this code I sort the worksheet by order of this column and them add subtotals at changes in this column.

Previously I wanted the code to select copy data from columns B to D, but now I want it to select copy columns B,C, & E.

A text box is used to select was data to copy, if for example U5 to U15 was all value 04 and I select 04 in the text box and run the code it would select B5 to D15, but I now want B, C & E.

There is however a small problem with the existing code in that if the select value is only on 1 row it select copies + the Subtotal row + 1 extra row.

LRIS = Range("B" & rng.Row).End(xlDown).Row
Range("B" & rng.Row & ":e" & LRIS).Select
Selection.Copy
'x = 0
'For i = 1 To Range("u65536&quot.End(xlUp).Row

'If Range("u" & i).Text = ComboBox1.Text Then
' If x < 1 Then
' rgSel = &quot;B&quot; & i & &quot;:e&quot; & i

' Else
' rgSel = rgSel & &quot;,B&quot; & i & &quot;e&quot; & i

'End If
'x = x + 1
'Else

'End If

'Next i
'Range(rgSel).Select
'Selection.Copy

Confused - I know I am

Please help!

Thanks

Andrew

 

[Zathras]

Here is a routine to determine the range that you want to copy (and a test routine to demo it):
[blue]

Option Explicit

Sub test()
   GetDesiredRange("02").Select
   MsgBox Selection.Address
End Sub

Function GetDesiredRange(UCode As String) As Range
Const COL_CODES = "U"
Const COL_COPYCOLS = "B:C,E:E"
Dim rCodes As Range
Dim rRows As Range
Dim nRow As Long
Dim nMinRow As Long
Dim nMaxRow As Long

[green]

  ' Set a range for where the codes are

[/color]

  With ActiveSheet
    Set rCodes = Intersect(.UsedRange, .Columns(COL_CODES))
  End With

[green]

  ' Find top and bottom rows for specified code

[/color]

  With rCodes
    nMinRow = 65536
    nMaxRow = 0
    For nRow = .Row To .Rows.Count - .Row + 1
      If rCodes(nRow).Value = UCode Then
        If nRow < nMinRow Then nMinRow = nRow
        If nRow > nMaxRow Then nMaxRow = nRow
      End If
    Next nRow
  End With

[green]

  ' Set range for desired rows/columns

[/color]

  If nMaxRow = 0 Then
    MsgBox "Invalid input: " & UCode
    Set GetDesiredRange = Nothing
  Else
    Set rRows = Rows(nMinRow & ":" & nMaxRow)
    Set GetDesiredRange = Intersect(rRows, Range(COL_COPYCOLS))
  End If

[green]

  ' Cleanup

[/color]

  Set rCodes = Nothing
  Set rRows = Nothing
End Function

[/color]
In your case, you should be able to use it this way:
[blue]

Sub test()
   GetDesiredRange(ComboBox1.Text).Select
   MsgBox Selection.Address
End Sub

[/color]

 

[APElliott]

Thanks Zathras,

Unfortunately this is way beyond me. I can do bits but nothing like what you've suggested.

You couldn't help further could you, this is the full code I was using:

Private Sub Image13_Click()
msheet = ActiveSheet.Name
Select Case msheet
Case &quot;BoQ&quot;
ans = MsgBox(&quot;Is The BoQ In Subcontract Order?&quot;, vbYesNoCancel)
Select Case ans
Case vbYes
ActiveSheet.Outline.ShowLevels RowLevels:=3
Range(&quot;u:u&quot.Select
Set rng = Selection.Find(What:=ComboBox1.Text, LookIn:=xlValues, LookAt:=xlWhole)
If rng Is Nothing Then
MsgBox &quot;THIS SUBCONTRACTOR DOESN'T EXIST!&quot;
ActiveSheet.Outline.ShowLevels RowLevels:=2
Exit Sub
End If

LRIS = Range(&quot;B&quot; & rng.Row).End(xlDown).Row
Range(&quot;B&quot; & rng.Row & &quot;&quot; & LRIS).Select
Selection.Copy
'x = 0
'For i = 1 To Range(&quot;u65536&quot.End(xlUp).Row

'If Range(&quot;u&quot; & i).Text = ComboBox1.Text Then
' If x < 1 Then
' rgSel = &quot;B&quot; & i & &quot;&quot; & i

' Else
' rgSel = rgSel & &quot;,B&quot; & i & &quot;D&quot; & i

'End If
'x = x + 1
'Else

'End If

'Next i
'Range(rgSel).Select
'Selection.Copy
End Select
Case vbNo
MsgBox &quot;Please Reorder Your BoQ To 'Sub Ref' Order!&quot;
Exit Sub
Case vbCancel
Exit Sub
Case Else
MsgBox &quot;Please Select BoQ To Select Information!&quot;
End Select
End Sub

Thanks

Andrew

 

[APElliott]

Sorry Zathras,

May be I should have just tried putting it all in before opening my big mouth!

Works a treat!

Cheers,

Andrew