Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

43060 / 76732

←次へ　｜　前へ→


	【38729】Re:シート間で同条件の並べ替え

ピッコロ - 06/6/9(金) 9:04 -


	引用なし

	パスワード

返事が遅くなり申し訳なく思っています。
私の説明不足や勉強不足のところもあり
提示していただいたコードが反映されてませんが
ナイスプログラムさんが発言されていたように配列で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

4 hits

▼

【38403】シート間で同条件の並べ替え ピッコロ 06/6/1(木) 23:27