ExcelVBAでボタンを押すとこれを自動的に作成できるようにしたのですが、 どうすればいいですか?

画像

ベストアンサー

0

・A1を基準としたセル範囲の表を、H2より右に項目列が並べ下に向かって表を作成する。(A1基準⇒H2基準) すみません。これです。

ThanksImg質問者からのお礼コメント

シンプルでわかりやすかったです。 ありがとうございました!

お礼日時:5/6 18:48

その他の回答(3件)

1

アクティブセルを基準に20行5列の表を作ります。 表の大きさを変えたい場合は r = 20 c = 5 の部分を変えてください。 図はActiveCellがH2で実行した場合です。 Sub sample() Dim rng As Range Dim r As Long Dim c As Long r = 20 c = 5 Set rng = ActiveCell rng.Resize(r + 1, c + 1).ClearContents rng.Resize(r + 1, c + 1).Borders.LineStyle = xlContinuous rng.Range("A1").Value = "No" rng.Range("A2").Resize(r, 1).Formula = "=Row(A1)" rng.Range("A2").Resize(r, 1).Value = rng.Range("A2").Resize(r, 1).Value rng.Range("B1").Resize(1, c).Formula = "=SUBSTITUTE(Address(Row(A1), Column(A1), 4),""1"","""")" rng.Range("B1").Resize(1, c).Value = rng.Range("B1").Resize(1, c).Value rng.Range("A1").Resize(1, c + 1).Interior.ColorIndex = 8 End Sub

1人がナイス!しています

1

何もないシートに作表出来ます。 シートの範囲外には作表出来ない様にしてあります。 Sub MakeChart() Dim I As Long, J As Long Dim No() As Long Dim ItemName() As String Const C_ROW = 21 Const C_COL = 6 If Selection.Count <> 1 Then MsgBox "基準になるセルは1つです。" Exit Sub End If If Selection.Column > Columns.Count - C_COL + 1 Or _ Selection.Row > Rows.Count - C_ROW + 1 Then MsgBox "指定基準位置では表がシートに収まりません。" Exit Sub End If ReDim ItemName(1 To 1, 1 To C_COL) ReDim No(1 To C_ROW - 1, 1 To 1) ItemName(1, 1) = "No" For I = 2 To C_COL ItemName(1, I) = Chr(63 + I) Next I For I = 1 To C_ROW - 1 No(I, 1) = I Next I Selection.Resize(, C_COL) = ItemName Selection.Resize(, C_COL).Interior.Color = RGB(200, 255, 255) Selection.Offset(1).Resize(C_ROW - 1) = No Selection.CurrentRegion.Borders.LineStyle = xlContinuous End Sub

1人がナイス!しています

1

こんな感じで確認願います。 Sub 罫表の作成() Dim WS As Worksheet Set WS = ActiveSheet Dim AC As Range Set AC = ActiveCell Dim cRow As Long Dim cCol As Long cRow = AC.Row cCol = AC.Column WS.UsedRange.Clear Dim i As Long, j As Long WS.Cells(cRow, cCol) = "No" WS.Cells(cRow, cCol + 1) = "A" WS.Cells(cRow, cCol + 2) = "B" WS.Cells(cRow, cCol + 3) = "C" WS.Cells(cRow, cCol + 4) = "D" WS.Cells(cRow, cCol + 5) = "E" For i = 1 To 20 WS.Cells(cRow + i, cCol) = i Next Call 罫線を引く(WS, cRow, cCol) WS.Cells(cRow, cCol).Select End Sub Sub 罫線を引く(WS As Worksheet, cR As Long, cC As Long) WS.Cells(cR, cC).Resize(1, 6).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 16251315 .TintAndShade = 0 .PatternTintAndShade = 0 End With WS.Cells(cR, cC).Resize(21, 6).Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With End Sub

画像

1人がナイス!しています

Senさんのプログラムは簡潔ですばらしいですが2点キズがあります。 その1:シートの全選択をしてボタンクリックするとオーバーフローとなります。 If Selection.Count <> 1 Then MsgBox "基準になるセルは1つです。" Exit Sub End If <対策> if instr(Selectio.address,":") > 0 then MsgBox "基準になるセルは1つです。" Exit Sub End If その2:ヘッダーは一つ一つ項目設定した方がいいと思われます。 ABCDEは項目として使う名称なら問題ないですが・・・ For I = 2 To C_COL ItemName(1, I) = Chr(63 + I) Next I