celdata veranderen in ander format

[Roughneck]

Ik heb een VBAcode nodig waarbij de data in een cel veranderd word in een ander format met leestekens.

Voorbeeld kolom A staat op celeigenschappen Speciaal met dit formaat: 000"-"000"."000"."00"-"00"-"00
Vervolgens "plakt" iemand een getal in de cel waarbij de originele celindeling word overschreven. Daar kun je niets aan veranderen,m.i.

Nou wil ik voor het opslaan, het inhoud van de cel weer terugveranderen naar het formaat 000"-"000"."000"."00"-"00"-"00. Dit lukt me wel, maar niet het daadwerkelijk veranderen van de reeds bestaande data in de cellen.

Wie helpt me?

 

[Elsendoorn2134]

Roughneck

Je kunt zonder ploblemen de format na plakken aanpassen.
Onderstaande macro verandert alle cellen in kolom A in het gewenste format
nadat een cel veranderd is door bij voorbeeld invoer of kopieren.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target(1, 1), Range("A:A")) Is Nothing Then
        Target.NumberFormat = "000""-""000"".""000"".""00""-""00""-""00"
    End If
End Sub

Veel succes.

 

[Roughneck]

Hoe krijg ik dit ingebouwd in een reeds bestaande VBA private sub?

Krijg een syntaxisfout? IK heb dit stukje code ingepast:

If Not Intersect(Target(1, 1), Range("A:A")) Is Nothing Then
Target.NumberFormat = "000""-""000"".""000"".""00""-""00""-""00"
End If

Dit is de reeds bestaande code:

Private Sub Opslaan_Click()



If Range("C4").Value = "" Then

Range("C4").Interior.ColorIndex = 37
      a = MsgBox("Vul een aansluitnummer in de blauw gekleurde cel", vbOKOnly)

         Exit Sub
    End If
    


With Range("A4:H" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row - 1)
    .Sort Key1:=Range("B4"), Order1:=xlDescending, Header:=xlGuess
    .Interior.ColorIndex = 0
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
       With .Font
            .Name = "Verdana"
            .Size = 10
            .ColorIndex = xlAutomatic
            
        End With
    
    
    Dim Bestandsnaam As String
  Dim Sysdate
  Dim tel As Integer, Letter As String
    Dim lastSaved As Date, antw As Integer
  Sysdate = Format(Date, "yyyymmdd")
  tel = 0
  Do
    If tel > 0 Then
      Letter = "-" & LCase(Replace(Left(Cells(1, tel).Address, 3), "$", "")) 'vertaal teller naar een kolomletter
    Else
      Letter = ""
    End If
    Bestandsnaam$ = "G:\" & [C4] & "-" & Sysdate & Letter & ".xls"  'bestand heet straks zo
    If Dir(Bestandsnaam$) = "" Then                        'bestaat die naam al in die directory ?
    
    
    If tel > 0 Then
        antw = MsgBox("Er is eerder vandaag een Borderel voor deze werkgever opgeslagen" & Chr(10) & Chr(10) & "Bestand wordt opgeslagen met een volg-letter", vbYesNo, "  Het bestand bestaat al.....")
      Else
        antw = vbYes
      End If
      
     If antw = vbYes Then
     
    
    Unprotect
      
    ActiveSheet.Shapes("Opslaan").Delete                             'voordat bestand word opgeslagen word de macroknop verwijderd
    ActiveSheet.Shapes("Invoegen").Delete                             'voordat bestand word opgeslagen word de macroknop verwijderd
    Application.ScreenUpdating = False
    Drij = Range("C4").End(xlDown).Row + 3
    Urij = Range("A65500").End(xlUp).Row - 1
  
        For verwijder = Urij To Drij Step -1
             Rows(verwijder).EntireRow.Delete
        Next
  
Application.ScreenUpdating = True

    'Protect                                               'werkboek beschermen voordat word opgeslagen
      
      ActiveWorkbook.SaveAs Bestandsnaam$                  'bestand opslaan
      
      MsgBox "Het bestand         " & "'" & [C4] & "-" & Sysdate & Letter & "'" & "         is opgeslagen," & Chr(10) & Chr(10) & "en uitgeprint!"
      End If
             
      tel = 0                                              'teller op 0 zetten om uit de loop te komen
    Else
      tel = tel + 1                                        'bestand bestond al, dus teller 1 ophogen
    lastSaved = FileDateTime(Bestandsnaam$)
    End If
    If tel > Columns.Count Then MsgBox "Paniek": Exit Sub
  Loop While tel <> 0

End With

        ActiveSheet.PrintPreview                                    'afdrukvoorbeeld
        'ActiveSheet.PrintOut copies:=1                              'effectief afdrukken



End Sub


Private Sub Invoegen_Click()
Regel = InputBox("Hoeveel regels wil je erbij?")
ActiveSheet.Unprotect
On Error GoTo Fout
For i = 1 To Regel
  Rij = ActiveSheet.Range("F65500").End(xlUp).Row - 1
  Rows(Rij).EntireRow.Copy
  Rows(Rij).EntireRow.Insert Shift:=xlShiftDown
  Rows(Rij + 1).PasteSpecial Paste:=xlFormulas
Next i
Fout: ActiveSheet.Protect
End Sub

 

[Thankyou]

Nou is VBA niet mijn ding, doe mij de formules maar.

Volgens mij moet je het hele stukje van Elsendoorn2134

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target(1, 1), Range("A:A")) Is Nothing Then
Target.NumberFormat = "000""-""000"".""000"".""00""-""00""-""00"
End If
End Sub

in het VBA-Blad (of hoe het ook heten mag )wat bij het betreffende werkblad hoort plakken.

Zover ik de code kan lezen staat er: Als er iets op het werkblad veranderd loop dan de celopmaak van kolom A na.

Succes,

 

[Roughneck]

Nee, het stukje moet geactiveerd worden met de druk op een knop in het werkblad (opslaan) en dat is al een private sub op zich. de end sub staat dus helemaal onderaan, ik kan dit stukje dus niet 1 op 1 in de bestaande code kopieeren, want vba heeft moeite met 2 private subs onder één command button. Hoop dat ik het een beetje begrijpelijk heb uitgelegd voor je?

 

[cow18]

zet ergens in die macro onderstaande regel

sheets("MijnBlad").columns("A").NumberFormat = "000""-""000"".""000"".""00""-""00""-""00"

 

[Roughneck]

Hij veranderd op deze manier inderdaad de eigenschappen van de kolom, maar reeds gevulde cellen (geplakt) laat dit commando ongemoeid.
Hij zou niet alleen de eigenschappen dus aan moeten passen maar meteen ook de data veranderen.

Ik wil gebruikers juist niet vragen om plakken speciaal te gebruiken, mijn ervaring is dat dit voor sommigen al teveel gevraagd is.
Daarom plakken gewoon, en bij het opslaan, veranderen in het leesbare formaat.

Natuurlijk kan ik de kolom al die eigenschappen meegeven vanaf het begin, maar plakken overschrijft die eigenschappen weer, en daarom wil ik dat met de opslagknop-macro weer juist maken.

Misschien handig om te weten: deze kolom is vooraf gedefinieerd als TEKST.

 

[Roughneck]

En toen bleef het verdacht stil. Ben bang dat ik nu iets heb waar nog niet eerder iets voor bedacht is, of kan het gewoon niet?