| |
返事が遅くなり申し訳なく思っています。
私の説明不足や勉強不足のところもあり
提示していただいたコードが反映されてませんが
ナイスプログラムさんが発言されていたように配列でDBシート全体を取得しました。
そして集計シートの名前の左横の列に電話番号の列を挿入し
電話番号の列を非表示とすることにより
画面表示としては自分が思うようになったと思います。
（コードに関しては満足でない腑に落ちないところが一箇所あり妥協しましたが・・・）
下記のコード関してご指摘があれば嬉しく思います。
Sub test2()
Dim 行, 名前セル, 電話セル
行 = Range("F65535").End(xlUp).Row
名前セル = Range("C65535").End(xlUp)
電話セル = Range("B65535").End(xlUp)
ReDim Arrange(行, 6)
Dim 集計行, tel_number
Dim sh1, sh3
Dim i, j
Set sh1 = Worksheets("DB")
Set sh3 = Worksheets("集計")
For i = 1 To 行
For j = 1 To Columns("F").Column
Arrange(i, j) = sh1.Cells(i, j).Value
If Arrange(i, j) = 名前セル Then
sh1.Range(Cells(i, j), Cells(i, j - 1)).Copy
sh3.Activate
Columns("A:A").EntireColumn.Hidden = False
sh3.Range("A65536").End(xlUp).Offset(1).Insert
集計行 = sh3.Range("B65536").End(xlUp).Row - 1
Range("B" & 集計行).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
sh3.Range(Cells(集計行, 3), Cells(集計行 + 1, 7)).Select
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlDouble
.Weight = xlThick
End With
sh1.Activate
Application.CutCopyMode = False
End If
Next
Next
If Arrange(行, 2) = 電話セル Then
sh1.Range("A1").Sort _
Key1:=sh1.Columns("B"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
Application.AddCustomList ListArray:=sh1.Range(sh1.Cells(1, 2), sh1.Cells(行, 2))
tel_number = Application.CustomListCount
sh3.Activate
sh3.Range(sh3.Cells(1, 1), sh3.Cells(集計行, 7)).Sort _
Key1:=sh3.Range("A1"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=tel_number, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlStroke
Columns("A:A").EntireColumn.Hidden = True
Application.DeleteCustomList ListNum:=tel_number
End If
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 06/6/3(土) 23:25 -
