VBA datum formateren

Status
Niet open voor verdere reacties.
S

SandyH

Gebruiker
Lid geworden
29 jan 2012
Berichten
113
Hallo

Onderstaande code haalt de datum uit een veld en voegt dan een kolom in, waarin op elke regel de datum wordt ingevuld.
De datum die opgehaald wordt zie er zo uit 10/05/2019 9:40:14.
Ik wil enkel dd/mm/yyyy laten invullen dus geen uur.

Waar (en hoe) vul ik dit aan in onderstaande code ?

With Sheets("Page1")
.Columns(1).Insert
.Range("B2:B" & .Cells(.Rows.Count, 2).End(xlUp).Row).SpecialCells(2, 2).Offset(, -1).Value = Cells(Columns.Count, "M").End(xlUp)
End With

bedankt alvast !
 
oesje, ik dacht dat mijn code voldoende zou zijn :)

Hierbij voorbeeldje dat ik beetje opgekuist naar een neutraal bestandje.
en dit is mijn code :


Sub stockfile()
Application.ScreenUpdating = True

'selecteer kolommen A tem P en unmerge deze kolommen

Columns("A:p").Select
Selection.UnMerge

'wissen van de afbeelding van het logo

ActiveSheet.Shapes.Range(Array("DSS_Paper_rgb.jpeg")).Select
Selection.Delete


'invullen lege velden met de juiste waarden

Dim c

With Sheets("Page1")
For Each c In .Range("A10:A" & .Cells(Rows.Count, 1).End(xlUp).Row)

If Cells(c.Row, "A") = Empty Then Cells(c.Row, "A").Value = c.Offset(-1, 0).Value
If Cells(c.Row, "B") = Empty Then Cells(c.Row, "B").Value = c.Offset(-1, 1).Value
If Cells(c.Row, "C") = Empty Then Cells(c.Row, "C").Value = c.Offset(-1, 2).Value
If Cells(c.Row, "D") = Empty Then Cells(c.Row, "D").Value = c.Offset(-1, 3).Value


Next
End With

'kolom invoegen en datum invullen

With Sheets("Page1")
.Columns(1).Insert
.Range("B2:B" & .Cells(.Rows.Count, 2).End(xlUp).Row).SpecialCells(2, 2).Offset(, -1).Value = Cells(Columns.Count, "M").End(xlUp)
End With

'wissen van lege rijen - kan best door copy paste specials in kolom M en dan de lege rijen wissen
Columns("M:M").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete


' 'filter om overbodige rijen weg te doen (met titels)
' 'filter op verkoop binnendienst en 1 (om laatste blauwe rij te wissen)
'
' Range("A1").Select
' Selection.AutoFilter
' ActiveSheet.Range("$A$1:$K$2014").AutoFilter Field:=2, Criteria1:="=1", _
' Operator:=xlOr, Criteria2:="=Verkoop binnendienst"
' Selection.CurrentRegion.Select
' Selection.EntireRow.Delete
'
''vanaf hier poging om gegevens te kopieren naar analysevolledigestock
'
' ' With Sheets("Page1")
'' .Range("A2:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
'' Sheets("Data Stock").Cells(Rows.Count, 1).End(xlUp).Offset(1)
'' End With


End Sub
 
bijlage, lukte niet om toe te voegen via 'snel reageren'
 

Bijlagen

  • voorbeeld.xlsx
    28,4 KB · Weergaven: 28
sorry, intussen eens het vastgepinde bericht gelezen :

Code: 
Sub stockfile()
Application.ScreenUpdating = True

'selecteer kolommen A tem P en unmerge deze kolommen

    Columns("A:P").Select
    Selection.UnMerge
 
    
'invullen lege velden met de juiste waarden

   Dim c
    
   With Sheets("Page1")
   For Each c In .Range("A10:A" & .Cells(Rows.Count, 1).End(xlUp).Row)

   If Cells(c.Row, "A") = Empty Then Cells(c.Row, "A").Value = c.Offset(-1, 0).Value
   If Cells(c.Row, "B") = Empty Then Cells(c.Row, "B").Value = c.Offset(-1, 1).Value
   If Cells(c.Row, "C") = Empty Then Cells(c.Row, "C").Value = c.Offset(-1, 2).Value
   If Cells(c.Row, "D") = Empty Then Cells(c.Row, "D").Value = c.Offset(-1, 3).Value
  

Next
End With

'kolom invoegen en datum invullen

With Sheets("Page1")
    .Columns(1).Insert
    .Range("B2:B" & .Cells(.Rows.Count, 2).End(xlUp).Row).SpecialCells(2, 2).Offset(, -1).Value = Cells(Columns.Count, "M").End(xlUp)
End With

'wissen van lege rijen - kan best door copy paste specials in kolom M en dan de lege rijen wissen
    Columns("M:M").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.Delete

End Sub
 
Stel dat de datums met tijden zich bevinden ik kolom A, misschien dat dit werkt:

Code: 
Range("A:A").NumberFormat = "dd/mm/yyyy"
 
Laatst bewerkt:
Probeer select te vermijden. Het aanzetten van ScreenUpdating is ook niet bevorderlijk voor de snelheid. Zet ook elke actie die je in/op een bepaald werkblad doet binnen de With en End With.

Code: 
Sub VenA()
  Dim r As Range
  Application.ScreenUpdating = False
  With Sheets("Page1")
    .Cells.UnMerge
    Set r = .Range("A9:P" & .Cells(Rows.Count, 1).End(xlUp).Row)
    On Error Resume Next 'Geen Specialcells gevonden
    r.Resize(, 4).SpecialCells(4).FormulaR1C1 = "=R[-1]C"
    r = r.Value
    .Columns(1).Insert
    .Cells(9, 1).Resize(r.Rows.Count) = Format(.Cells(Rows.Count, 13).End(xlUp), "mm/dd/yyyy")
    .Columns(13).SpecialCells(4).EntireRow.Delete
  End With
End Sub
 
Laatst bewerkt:
Of:
Code: 
Sub hsv()
 Columns(1).Insert
 Range("a9", Cells(Rows.Count, 13).End(xlUp)) = Fix(Cells(Rows.Count, 13).End(xlUp))
End Sub
 
Misschien nog beter om het binnen r te houden
Code: 
r.Cells(1).Resize(r.Rows.Count).Offset(, -1) = Int(.Cells(Rows.Count, 13).End(xlUp))
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan