If then tekstboks

hejsa
måske denne kode kan bruges
Sub beskedboks()
' viser beskedboks hvis celle = 1
    Dim b As Integer
    Range("A40").Select
        Do Until ActiveCell.Value = ""
        If ActiveCell.Value <> 1 Then
        ActiveCell.Offset(1, 0).Select
        Else
        b = ActiveCell
        MsgBox "Der står " & b & " i cellen", vbOKOnly
        ActiveCell.Offset(1, 0).Select
        End If
        Loop
    Range("A39").Select

End Sub

/Amtoft

Hej L_Amtoft


Tak for dit svar, der virker perfekt, men det var ikke
en besked boks jeg efterlyste.

Jeg skal have en celle til at blive 3 x længere, hvis den har en værdi (eks 1).

Jeg kan ikke bruge betinget format.
(Alle celler har allerede en betinget formatering, jeg kan derfor ikke lægge flere formateringer sammen)

Så jeg ville lægge en tekstboks oven på cellen, med værdien fra cellen.

MVH

Tony

Hej Newbee1

Den celle du skal ha´ gjort længere ... kan den sammeflettes med nabo cellerne ??

Med venlig hilsen, Nicolai

Hej Newbee1

Hvis din aktive celle må flettes med nabo cellerne ?
Så prøv følgende VBA kode.

I eksemplet aktiveres koden hver gang værdien i celle A1 ændres.
Er værdien i cellen 1 ... flettes cellerne A1-D1.
Er værdien ikke 1 ... genetableres cellerne.

Kopier koden ind bag det aktuelle ark.

-------------


Private Sub Worksheet_Change(ByVal Target As Range)


    'hvis celle A1 er den aktive celle
    If Target.Address = "$A$1" Then

        'hvis værdien i den aktive celle er 1
        If Target.Value = 1 Then
       
            'vælg og merge området fra og med den aktive celle til og med 3 kolonner til højre
            ActiveSheet.Range(Target, Target.Offset(0, 3)).Select
            Selection.Merge
           
            'vælg den aktive celle
            ActiveCell.Select
           
           
        'ellers
        Else
       
            'vælg og merge området fra og med den aktive celle til og med 3 kolonner til højre
            ActiveSheet.Range(Target, Target.Offset(0, 3)).Select
            Selection.UnMerge
       
           
            'vælg den aktive celle
            ActiveCell.Select
           
        End If
           
 
    End If


End Sub



Med venlig hilsen, Nicolai

Hej Lalocin

Jeg tror godt din ide kan virke.

Alle felter i regenearket har en udregning, men der vil altid være plads til at sammenflette celler, hvis bare at cellerne kommer tilbage det oprindelige igen.

Men jeg kan ikke få din kode til at virke
(Jeg er ikke på hjemmebane i VBA)

Fejlmeddelse
Obejct Required
If Target.Address = "$A$1" Then

Jeg har skrevet et 1-tal i celle A1.

Jeg skal også have det til at virke på hele arket.

Tak for din hjælp så langt

MVH

Tony

Hej Tony

Uha ... Jeg er ikke Dansk mester i fejlmeddelelser :o)


Hvilken version af Excel benytter du ?
Hvor/hvordan har du oprettet min kodestump ?

Og har du evt. en mail, hvor til jeg kan poste mit Excel eksempel ?

Med venlig hilsen, Nicolai

Hej Tony

Du kan evt. prøve følgende kodestump ... som er en kopi af #4, hvor Target er byttet ud med Avtivecell.

På dit pågældende ark/sheet ... Tast Alt + F11
... hvorefter VBA editoren forhåbentligt åbner :o)

Dobbeltklik på det aktuelle arknavn (typisk i vinduet til venstre?)

Vælg arkets Change hændelse (typisk i dropdown menuen øverst til højre)


Kopier nedenstående kode ind mellem linierne:

Private Sub Worksheet_Change(ByVal activecell As Range)

og

End Sub


---------------------------


'hvis celle A1 er den aktive celle
    If activecell.Address = "$A$1" Then

        'hvis værdien i den aktive celle er 1
        If activecell.Value = 1 Then
       
            'vælg og merge området fra og med den aktive celle til og med 3 rækker ned
            ActiveSheet.Range(activecell, activecell.Offset(0, 3)).Select
            Selection.Merge
           
            'vælg den aktive celle
            activecell.Select
           
           
        'ellers
        Else
       
            'vælg og merge området fra og med den aktive celle til og med 3 rækker ned
            ActiveSheet.Range(activecell, activecell.Offset(0, 3)).Select
            Selection.UnMerge
       
           
            'vælg den aktive celle
            activecell.Select
           
        End If
           
 
    End If


------------------


Med venlig hilsen, Nicolai

Hej Nicolai


Hvis du gider må du meget gerne sende en test.


Tony.hansson$gmail.com


MVH

Tony

Hej Tony

Mail´en er på vej.

Med venlig hilsen, Nicolai

Hej Tony

For go´ ordens skyld så kommer her lige koden, som opretter, farvelægger og formaterer tekstboksene på dit regneark, hvis den enkelte celleværdi er 1:

----------


'Indsæt tekstboks procedure
Sub IndsætTekstboks()
 
    'for hver celle i området "A1:H5" på det pågældende ark
    For Each cell In ActiveSheet.Range("A1:H5")
 
            'hvis celleværdien er 1
            If cell.Text = "1" Then
               
                                         
                'vælg cellen
                cell.Select
               
                'tilføj tekstboks over den valgte celle .... Bredden på tekstboksen bestemmes af tallet i 4. argument (her 50)
              With ActiveSheet.Shapes.AddTextBox(msoTextOrientationHorizontal, activecell.Left, activecell.Top, 50, activecell.Height)
             
                   
                    'fyld tekstboksen med den ønskede RGB farve
                    .Fill.ForeColor.RGB = RGB(192, 192, 192)
                   
                    'skriv den underliggende celles værdi i tekstboksen
                    .TextFrame.Characters.Text = cell.Value
                   
                    'kursiv formatering af teksten
                    .TextFrame.Characters.Font.Italic = True
                   
                    'fed formatering af teksten
                    .TextFrame.Characters.Font.Bold = True
                   
                    'font størrelse
                    .TextFrame.Characters.Font.Size = 10
               
                         
                End With
                   
            End If

    Next
     
End Sub


Med venlig hilsen, Nicolai