Decimal tab in vba

Status
Niet open voor verdere reacties.
Oké dank (net terug van vakantie :)). In de bijlage heb ik een Word-bestand geplaatst met een geplakte tabel vanuit Excel. Ik heb de code hiermee ook getest en alleen de eerste tabel wordt goed bewerkt met alle comma's netjes onder elkaar.

In Excel maak ik de tabellen met de code:
Code: 
Sub tabelformat()
'Selecteer de gehele te maken tabel inclusief tabel titel

crij = Selection.Row
ckol = Selection.Column
lRij = crij + Selection.Rows.Count - 1
lkol = ckol + Selection.Columns.Count - 1
    
'weghalen lijnen
With Selection
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
End With
    
'Opmaak tabeltitel
With Selection.Rows(1)
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlTop
    .MergeCells = True
End With

With Selection.Rows(1).Font
    .Size = 11
    .Name = "Arial"
End With

'Instellen fonts gehele tabel
With Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1, Selection.Columns.Count).Font
    .Name = "Arial"
    .Size = 8
End With

'Vetmaken eerste regel tabelkop
Selection.Rows(2).Font.Bold = True
    
'Opmaak tabelkop en tabelinhoud
c = InputBox("Uit hoeveel regels bestaat de tabelkop?", "Tabelopmaak", 1)

On Error Resume Next
For Each cl In Selection
    If IsDate(cl.Value) = True Then    'controle op datumveld
        cl.Value
    ElseIf Int(cl.Value) = cl.Value Then
        cl.NumberFormat = "0"
    ElseIf cl.Value = Empty Then
        cl.Value = Empty
    ElseIf cl.Value > 100000 Then
     cl.NumberFormat = "0.0E+00"
    ElseIf cl.Value > 100 Then
      cl.NumberFormat = "0"
    ElseIf cl.Value > 10 Then
      cl.NumberFormat = "0.00"
    ElseIf cl.Value > 1 Then
      cl.NumberFormat = "0.00"
    ElseIf cl.Value > 0.1 Then
      cl.NumberFormat = "0.00"
    ElseIf cl.Value > 0.001 Then
      cl.NumberFormat = "0.0000"
    ElseIf cl.Value > 0.0001 Then
      cl.NumberFormat = "0.0000"
    ElseIf cl.Value > 0.00001 Then
      cl.NumberFormat = "0.0E+00"
    ElseIf cl.Value > 0 Then
      cl.NumberFormat = "0.000"
      
    ElseIf cl.Value < -1 Then
      cl.NumberFormat = "0.0"
    ElseIf cl.Value < -0.1 Then
      cl.NumberFormat = "0.00"
    ElseIf cl.Value < -0.01 Then
      cl.NumberFormat = "0.00"
    ElseIf cl.Value < -0.001 Then
      cl.NumberFormat = "0.000"
    ElseIf cl.Value < -0.0001 Then
      cl.NumberFormat = "0.0000"
    ElseIf cl.Value < -0.00001 Then
      cl.NumberFormat = "0"
    End If
Next
    If c = 4 Then
        Selection.Offset(5).Borders(xlEdgeTop).LineStyle = xlDouble
        With Selection.Rows("2:5")
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlTop
        End With
        
        With Selection.Offset(5, 0).Resize(Selection.Rows.Count - 5, Selection.Columns.Count)
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlCenter
        End With
    ElseIf c = 3 Then
        Selection.Offset(4).Borders(xlEdgeTop).LineStyle = xlDouble
        With Selection.Rows("2:4")
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlTop
        End With
        
        With Selection.Offset(4, 0).Resize(Selection.Rows.Count - 4, Selection.Columns.Count)
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlCenter
        End With
        
    ElseIf c = 2 Then
        Selection.Offset(3).Borders(xlEdgeTop).LineStyle = xlDouble
        With Selection.Rows("2:3")
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlTop
        End With
        
        With Selection.Offset(3, 0).Resize(Selection.Rows.Count - 3, Selection.Columns.Count)
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlCenter
       End With
    ElseIf c = 1 Then
        Selection.Offset(2).Borders(xlEdgeTop).LineStyle = xlDouble
        With Selection.Rows(2)
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlTop
        End With

        With Selection.Offset(2, 0).Resize(Selection.Rows.Count - 2, Selection.Columns.Count)
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlCenter
        End With
    End If
    
    'plaatsen lijnen tabel
    With Selection.Offset(1).Resize(Selection.Rows.Count - 1, Selection.Columns.Count)
      .Borders(xlInsideVertical).LineStyle = xlContinuous
      .Borders(xlEdgeLeft).LineStyle = xlDouble
      .Borders(xlEdgeRight).LineStyle = xlDouble
      .Borders(xlEdgeBottom).LineStyle = xlDouble
      .Borders(xlEdgeTop).LineStyle = xlDouble
    End With
    
    Selection.Offset(1).Resize(Selection.Rows.Count - 1, Selection.Columns.Count).Columns(1).HorizontalAlignment = xlLeft
      
    If s Is Nothing And ss Is Nothing Then
        Exit Sub
    Else
        If k < lkol Then
            Range(Cells(r, k), Cells(lRij, lkol)).Select
            Selection.NumberFormat = "@"
        Else
            ActiveSheet.Range(A, ActiveSheet.Cells(r, k).End(xlDown)).Select
            Selection.NumberFormat = "@"
        End If
    End If
End Sub
 

Bijlagen

  • decimal tab 2.docx
    13 KB · Weergaven: 24
Laatst bewerkt:
Als ik er een object van maak dan kun je er niks meer mee in Word en dat is wel de bedoeling
 
Post het Excel bestandje er eens bij, met de daarbij gebruikte macro's
 
Nog geen tijd voor gehad; net een nieuw huis gekocht :).
 
dank je! Morgen een rustdag, dus dan kijk ik er wat uitgebreider naar.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan