Werte übertragen und zusätzlich Rahmen zeichnen

Hallo Zusammen,
Ich habe folgendes Problem:
Ich schreibe momentan mittels VBA ein Makro. Unteranderem soll es Folgendes beinhalten:
Auf einem 1. Excel Sheet steht eine (undefinierte) Anzahl an Werten untereinander. Nun soll das Makro diese Werte genauso übernehmen wie es auf dem 1. Sheet steht und auf einen 2. Sheet übertragen. Zusätzlich soll es aber noch einen Rahmen um jede Zelle ziehen, so dass ich am Ende auf dem 2. Sheet eine Tabelle mit Rahmen habe, die genau so viele Spalten beinhaltet, wie die Anzahl der Werte auf dem 1. Sheet. Dabei kann die Anzahl an Werten auf Sheet 1 natürlich jedes mal schwanken, so dass ich nicht einfach eine Maske auf Sheet 2 anfertigen kann, die dann nur jedes mal ausgefüllt werden müsste.
Ich hoffe ich habe mich verständlich ausgedrückt...
Fällt dafür jemandem eine Lösung ein?
Grüße,
Jochen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Servus Jochen,
meinst du das so?


Sub test()
Dim intLZ As Integer
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim rngTab1 As Range
Dim rngTab2 As Range
Dim Zelle As Range
Set ws = ThisWorkbook.Worksheets("Tabelle1")
Set ws2 = ThisWorkbook.Worksheets("Tabelle2")
ws2.UsedRange.Clear
intLZ = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range("A1:A" & intLZ).Copy Destination:=ws2.Range("A1")
Set rngTab2 = ws2.Range(ws2.Cells(1, 1), ws2.Cells(intLZ, intLZ))
For Each Zelle In rngTab2
Zelle.Borders(xlDiagonalDown).LineStyle = xlNone
Zelle.Borders(xlDiagonalUp).LineStyle = xlNone
With Zelle.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Zelle.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Zelle.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Zelle.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Zelle.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Zelle.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Next Zelle
Set Zelle = Nothing
Set rngTab1 = Nothing
Set rngTab2 = Nothing
Set ws2 = Nothing
Set ws = Nothing
End Sub

Grüße, Bernd

Public Sub Daten_und_Rahmen() Dim loLetzteQ As Long, loLetzteZ As Long Application.ScreenUpdating = False With Worksheets("Tabelle1") loLetzteQ = .Cells(.Rows.Count, 2).End(xlUp).Row .Range(.Cells(3, 2), .Cells(loLetzteQ, 2)).Copy With Worksheets("Tabelle3") loLetzteZ = .Cells(.Rows.Count, 2).End(xlUp).Offset(1).Row .Cells(loLetzteZ, 2).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False .Columns(2).HorizontalAlignment = xlCenter .Columns(2).Font.Bold = True loLetzteZ = .Cells(.Rows.Count, 2).End(xlUp).Row With .Range(.Cells(3, 2), .Cells(loLetzteZ, 11)) .Borders(xlEdgeLeft).LineStyle = xlContinuous .Borders.Weight = xlMedium .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders.Weight = xlMedium .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders.Weight = xlMedium .Borders(xlEdgeRight).LineStyle = xlContinuous .Borders.Weight = xlMedium .Borders(xlInsideVertical).LineStyle = xlContinuous .Borders.Weight = xlMedium .Borders(xlInsideHorizontal).LineStyle = xlContinuous .Borders.Weight = xlMedium End With End With End With End Sub

Beliebteste Forumthreads (12 Monate)

Werte übertragen und zusätzlich Rahmen zeichnen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread