Tabel maken met macro

[ingmar1]

Hallo,

Ik heb een vraag m.b.t. het maken van een tabel vanuit een macro. Ik heb 1 overzicht waar allemaal gegevens in staan en daar moet de macro verschillende overzichten van maken. Nu is het zo dat de onderste regel elke keer op een ander rij nummer zit. Nu kan ik wel er wel randen omheen krijgen met onderstaande macro, maar volgens mij moet dit een stuk eenvoudiger kunnen? Nu krijg ik namelijk regelmatig een melding dat er niet genoeg geheugen beschikbaar is. Kan iemand mij hier mee verder helpen?

    Columns("E:E").Select
    Selection.Style = "Currency"
    Range("A3").Select
    Selection.CurrentRegion.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    ActiveWindow.SmallScroll Down:=-15
    Range("A1:E1").Select
    Range("E1").Activate
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("A2:E2").Select
    Range("E2").Activate
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("E18").Select
    Columns("E:E").EntireColumn.AutoFit
            Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("E:E").Select
    Selection.Cut
    Range("C1").Select
    ActiveSheet.Paste
    Columns("E:E").Select
    Selection.Delete Shift:=xlToLeft
    Range("I8").Select

 

[Jack Nouws]

Hallo,

Kijk eens of je hier mee uit de voeten kunt.

Sub RANDEN()

    With [A1:E2,A3]
        .Borders(xlEdgeLeft).Weight = xlMedium
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlMedium
        .Borders(xlInsideVertical).Weight = xlThin
    End With

End Sub

Met vr gr
Jack

 

[ingmar1]

Ik heb het geprobeerd, maar hij zet nu alleen randen om a1: e2 en voor de rest alleen om a3.

 

[Jack Nouws]

Ik heb het geprobeerd, maar hij zet nu alleen randen om a1: e2 en voor de rest alleen om a3.

Hallo,

Ik heb mijn code afgeleid uit jou code. Ik weet ook niet hoe de opzet van je bestand is, daarom is het misschien makkelijker een voorbeeld bestandje te plaatsen (ontdaan van gevoelige informatie)

Met vr gr
Jack

 

[ingmar1]

Het betand ziet er ongeveer zo uit:

|Klantnummer | Klantnaam
|Artikelnummer| Omshrijving | Specificatie | Aantal |Omzet
| 555555 | Product X | Doos | 5 | €100,-
| 666666 | Product Y | Zak | 4 | €200,-
Totaal €300,-

Overal staan dus verticale en horizontale lijnen en eromheen een dikgedrukte rand. Het aantal regels is dus variabel.

Groeten,

Ingmar

 

[Jack Nouws]

Hallo,

Ik weet niet of er lege regels tussen de tabellen zitten?
Zoja, dan kun je met deze code vast wel uit de voeten.

Sub tst()

  For Each c In [A1:A500]
    If c.Value = "Klantnummer" Then
      With Cells(c.Row, 1).CurrentRegion
        .Borders(xlEdgeLeft).Weight = xlMedium
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlMedium
        .Borders(xlInsideVertical).Weight = xlThin
      End With
    End If
  Next
End Sub

Met vr gr
Jack

 

[ingmar1]

Nee, er zitten geen lege regels tussen de tabellen. Er staat 1 tabel per sheet. Verder is elke regel gevuld tot het totaal.

 

[ingmar1]

Wanneer je in cel a2 staat en vervolgens:
1. ctrl + shift + pijltje naar rechts en ctrl + shift inhouden en pijltje naar onder;
2. shift + 1 keer pijltje naar onder doet;

heb je de goede selectie. Hier moeten dus eigenlijk de randen omheen.

 

[ingmar1]

Ik heb het zelf nog even verder geprobeerd met je antwoord en het is gelukt!

Hartstikke bedankt voor de moeite.:thumb:

De macro zag er als volgt uit:

For Each c In [A1:A500]
If c.Value > "" Then
With Cells(c.Row, 1).CurrentRegion
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
End With
End If
Next

 

[Jack Nouws]

Hallo

Dan zal het zo ook wel lukken.

  For Each c In [A1:A500]
    If c.Value > "" Then
      With Cells(c.Row, 1).CurrentRegion
        .BorderAround , Weight:=xlMedium
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideHorizontal).Weight = xlThin
      End With
    End If
  Next

Met vr gr
Jack