| |
１度でＵＰできないので。
'基シート名, シート名, 増シート数, 設定行, 設定列
Sub TBL使用シート増(基シート名 As String, シート名 As String, 増シート数 As Integer, 設定行 As Long, 設定列 As Long)
Dim 使用列数 As Integer, RR As Integer, II As Integer
With Sheets(基シート名).UsedRange
使用列数 = .Cells(.Count).Column
End With
'使用列数 = Sheets(基シート名).UsedRange.Columns.Count
For II = 1 To Worksheets.Count
If ActiveSheet.Name = Worksheets(II).Name Then
On Error Resume Next
'完全な追加形式ではない場合、下記●の付いた５行のチェックをはずす。
'シート名 = Worksheets(II + 1).Name '●
'If Err <> 0 Then '●
増シート数 = 増シート数 + 1
'書式をコピーする。データが多いとろくに動かない。「ディスクがいっぱいです。」とのエラーになる
'Worksheets(基シート名).Copy after:=Worksheets(II)
'Worksheets(II + 1).Name = 基シート名 & "_" & 増シート数
'シート名 = Worksheets(II + 1).Name '基シート名 & "_" & 増シート数
'Worksheets(シート名).Range(Cells(設定行, 設定列 + カンマ数 + 1), Cells(改シート行, 設定列 + カンマ数 + 1)).ClearContents
'Worksheets(シート名).Shapes.Range(Array("Button 1", "Button 2", "Button 3")).Delete
'書式を追加後、コピー
Worksheets.Add after:=Worksheets(II)
ActiveSheet.Name = 基シート名 & "_" & 増シート数
シート名 = Worksheets(II + 1).Name
Application.ScreenUpdating = False
For RR = 1 To 使用列数
With Sheets(シート名)
.Columns(RR).NumberFormatLocal = Sheets(基シート名).Columns(RR).NumberFormatLocal
.Columns(RR).ColumnWidth = Sheets(基シート名).Columns(RR).ColumnWidth
End With
Next
Application.ScreenUpdating = True
' DoEvents
' Err.Clear '●
' On Error GoTo 0 '●
'End If '●
Worksheets(シート名).Select
Exit Sub
End If
Next
End Sub
'注）32767行までしか認識しない。
Function 書込み開始位置設定(設定行, 設定列) As Long
Dim エラー番号 As Integer
Dim 入力始点位置set As Object
On Error Resume Next
Set 入力始点位置set = Application.InputBox(Prompt:="書込む最初のセルをクリックして下さい。", _
Title:="書込み位置の選択", Default:=ActiveCell.Address, Type:=8)
If 入力始点位置set Is Nothing Then
入力始点位置set = Nothing
End
Else
設定行 = 入力始点位置set.Row
設定列 = 入力始点位置set.Column
End If
入力始点位置set = Nothing
End Function
|
|
Jaka
- 11/7/27(水) 15:43 -
