Adding contants controls

rhino4eva

rhino4eva

Active Member
Joined
Apr 1, 2009
Messages
260
Office Version
  1. 2010
Platform
  1. Windows
Sub test()
Sheets("1PLATE").Range("P25").Copy
Sheets("1PLATE").Range("C4:E11").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns, LookIn:=xlValues).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub


I am trying to develop a vba code to add auto add in my controls into a worksheet
the first line selects a text value and copies it
the second line looks to see if there is a empty cell thin the range I have defined ie 4 columns and eight rows

all is well until the 8th cell is already full.... it then fills the 9th row which is outside the range
I would like it to fill the first row of the next column

could anyone see what I am missing

Adam
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Sort by date Sort by votes
Re: help with adding contants controls

With the following code, if there's no text within C4:E11, the value from P24 is copied to C4. If there are no empty cells with C4:E11, a message will pop up to let you know. If you need help with making any changes, post back.

Code: 
Sub test()
    Dim ws As Worksheet
    Dim rFound As Range
    
    Set ws = Sheets("1PLATE")
    
    With ws.Range("C4:E11")
        On Error Resume Next
        Set rFound = .Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns, LookIn:=xlValues)
        On Error GoTo 0
        If rFound Is Nothing Then
            .Cells(1).Value = ws.Range("P25").Value
        ElseIf Intersect(rFound, .Cells(.Rows.Count, .Columns.Count)) Is Nothing Then
            If rFound.Row < .Rows(.Rows.Count).Row Then
                rFound.Offset(1, 0).Value = ws.Range("P25").Value
            Else
                rFound.Offset(-.Rows.Count + 1, 1).Value = ws.Range("P25").Value
            End If
        Else
            MsgBox "No empty cell found within " & .Address(0, 0) & ".", vbInformation
        End If
    End With
End Sub

Hope this helps!
 
Upvote 0
WOW this is brill and it really works

.... I didn't think anyone would get where I'm coming from
I would like to develop your code one step further tho

I would like to be able the repeat this feature over 3 more similar ranges with different copied controls
I tried to replace the set range and copied cell with variables
then setting them as required and calling this routine from another module

Adam
 
Upvote 0
Re: help with adding contants controls

Domenic said:
With the following code, if there's no text within C4:E11, the value from P24 is copied to C4. If there are no empty cells with C4:E11, a message will pop up to let you know. If you need help with making any changes, post back.

Code: 
Sub test()
    Dim ws As Worksheet
    Dim rFound As Range
    
    Set ws = Sheets("1PLATE")
    
    With ws.Range("C4:E11")
        On Error Resume Next
        Set rFound = .Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns, LookIn:=xlValues)
        On Error GoTo 0
        If rFound Is Nothing Then
            .Cells(1).Value = ws.Range("P25").Value
        ElseIf Intersect(rFound, .Cells(.Rows.Count, .Columns.Count)) Is Nothing Then
            If rFound.Row < .Rows(.Rows.Count).Row Then
                rFound.Offset(1, 0).Value = ws.Range("P25").Value
            Else
                rFound.Offset(-.Rows.Count + 1, 1).Value = ws.Range("P25").Value
            End If
        Else
            MsgBox "No empty cell found within " & .Address(0, 0) & ".", vbInformation
        End If
    End With
End Sub

Hope this helps!
Click to expand...

i would like to use your exellent code in a loop 8 times around
by variablizing (made up word) the fourth line ws.range("c4:e11") so i could change this range along with the
the copy/paste element ws.range("p25") to match my poor effort below where i have called your code CntrlEngine
several times and tried to change the varriable
and call it again

Sub PLATECNTRLS1()

'FLU
RespRange = "C4:E11" ' as ws.range to examine
poscon = "p25" 'the cell to copy /paste into the range
Call CntrlEngine

'RSV
RespRange = "F4:h11"
poscon = "p28"
Call CntrlEngine
RespRange = "F4:h11"
poscon = "p29"
Call CntrlEngine

'PF
RespRange = "I4:K11"
poscon = "p32"
Call CntrlEngine
RespRange = "I4:K11"
poscon = "p33"
Call CntrlEngine
RespRange = "i4:k11"
poscon = "p34"
Call CntrlEngine
'SWINE
RespRange = "L4:N11"
poscon = "p37"
Call CntrlEngine
RespRange = "L4:N11"
poscon = "p38"
Call CntrlEngine

Application.CutCopyMode = False
End Sub
 
Last edited:
Upvote 0
Re: help with adding contants controls

Try...

Code: 
[COLOR=darkblue]Sub[/COLOR] PLATECNTRLS1()

    [COLOR=green]'FLU[/COLOR]
    [COLOR=darkblue]Call[/COLOR] CntrlEngine("C4:E11", "P25")
    
    [COLOR=green]'RSV[/COLOR]
    [COLOR=darkblue]Call[/COLOR] CntrlEngine("F4:h11", "P28")
    
    [COLOR=green]'etc[/COLOR]
    '
    '
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]


[COLOR=darkblue]Sub[/COLOR] CntrlEngine(sRespRange [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR], sPoscon [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR])
    [COLOR=darkblue]Dim[/COLOR] ws [COLOR=darkblue]As[/COLOR] Worksheet
    [COLOR=darkblue]Dim[/COLOR] rFound [COLOR=darkblue]As[/COLOR] Range
    
    [COLOR=darkblue]Set[/COLOR] ws = Sheets("1PLATE")
    
    [COLOR=darkblue]With[/COLOR] ws.Range(sRespRange)
        [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
        [COLOR=darkblue]Set[/COLOR] rFound = .Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns, LookIn:=xlValues)
        [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0
        [COLOR=darkblue]If[/COLOR] rFound [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
            .Cells(1).Value = ws.Range(sPoscon).Value
        [COLOR=darkblue]ElseIf[/COLOR] Intersect(rFound, .Cells(.Rows.Count, .Columns.Count)) [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
            [COLOR=darkblue]If[/COLOR] rFound.Row < .Rows(.Rows.Count).Row [COLOR=darkblue]Then[/COLOR]
                rFound.Offset(1, 0).Value = ws.Range(sPoscon).Value
            [COLOR=darkblue]Else[/COLOR]
                rFound.Offset(-.Rows.Count + 1, 1).Value = ws.Range(sPoscon).Value
            [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
        [COLOR=darkblue]Else[/COLOR]
            MsgBox "No empty cell found within " & .Address(0, 0) & ".", vbInformation
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
[COLOR=darkblue]End[/COLOR] Sub

Hope this helps!
 
Upvote 0
Re: help with adding contants controls

thank you so much this is exactly what I had in mind .... I have now learnt anew technique that I will be able to implement over and over again:)
 
Upvote 0
Re: help with adding contants controls

i was just wondering if it possible to add a line into the cntrl engine that checks if the cntrl is already there before adding it again

Adam
 
Upvote 0
Re: help with adding contants controls

Try...

Code: 
[COLOR=darkblue]Sub[/COLOR] CntrlEngine(sRespRange [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR], sPoscon [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR])
    [COLOR=darkblue]Dim[/COLOR] ws [COLOR=darkblue]As[/COLOR] Worksheet
    [COLOR=darkblue]Dim[/COLOR] rFound [COLOR=darkblue]As[/COLOR] Range
    
    [COLOR=darkblue]Set[/COLOR] ws = Sheets("1PLATE")
    
    [COLOR=darkblue]With[/COLOR] ws.Range(sRespRange)
        [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
        [COLOR=darkblue]Set[/COLOR] rFound = .Find(ws.Range(sPoscon).Value, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0
        [COLOR=darkblue]If[/COLOR] rFound [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
            [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
            [COLOR=darkblue]Set[/COLOR] rFound = .Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns, LookIn:=xlValues)
            [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0
            [COLOR=darkblue]If[/COLOR] rFound [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
                .Cells(1).Value = ws.Range(sPoscon).Value
            [COLOR=darkblue]ElseIf[/COLOR] Intersect(rFound, .Cells(.Rows.Count, .Columns.Count)) [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
                [COLOR=darkblue]If[/COLOR] rFound.Row < .Rows(.Rows.Count).Row [COLOR=darkblue]Then[/COLOR]
                    rFound.Offset(1, 0).Value = ws.Range(sPoscon).Value
                [COLOR=darkblue]Else[/COLOR]
                    rFound.Offset(-.Rows.Count + 1, 1).Value = ws.Range(sPoscon).Value
                [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
            [COLOR=darkblue]Else[/COLOR]
                MsgBox "No empty cell found within " & .Address(0, 0) & ".", vbInformation
            [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
        [COLOR=darkblue]Else[/COLOR]
            MsgBox "The text value '" & ws.Range(sPoscon).Value & "' already exists within " & .Address(0, 0) & ".", vbInformation
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    [COLOR=darkblue]Set[/COLOR] ws = [COLOR=darkblue]Nothing[/COLOR]
    [COLOR=darkblue]Set[/COLOR] rFound = [COLOR=darkblue]Nothing[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

Hope this helps!
 
Upvote 0
Re: help with adding contants controls

Once again your knowledge of vba shows up my feeble attempts
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
how to add my signature with images to macro
Replies
1
Views
182
Domenic
D
H
  • Solved
Excel VBA file importing data from several files located in same folder -> challenge to copy data only (rest is working perfectly)
Replies
3
Views
166
NdNoviceHlp
NdNoviceHlp
P
  • Solved
VBA Find first empty cell in row
2
Replies
10
Views
2K
MARK858
MARK858
M
  • Question
Add in VBA Code to check zip code against pre-determined list
Replies
0
Views
176
mikefisher
M
B
  • Question
How to add rows added to a table to a new sheet
Replies
5
Views
465
kevin9999
K

Forum statistics

Threads
1,215,430
Messages
6,124,846
Members
449,194
Latest member
HellScout

Share this page

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
Back
Top