Excel VBA質問箱 IV

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

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


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

36105 / 76732

←次へ　｜　前へ→


	【45812】Re:どのようにやるのでしょうか？

Kein - 07/1/14(日) 23:42 -


	引用なし

	パスワード

こんな感じでどうでしょーか ?
ちょっとややこしいコードになりますが、テストは成功しています。

Sub LGV_Address()
　 Dim Cc As Long, i As Long, j As Long
　 Dim ErW As Long, Cnt As Long
　 Dim Ad As String
　 Dim MyV As Variant
　 Dim MyR As Range, C As Range, FR As Range
　
　 Set MyR = Worksheets("Sheet1").Range("A1").CurrentRegion
　 Cc = MyR.Columns.Count: Ad = MyR.Address
　 For i = 1 To MyR.Rows.Count
　　　If i = 1 Then
　　　　 j = 1
　　　Else
　　　　 j = j + Cc
　　　End If
　　　MyV = WorksheetFunction.Transpose(MyR.Rows(i).Value)
　　　Sheets("Sheet2").Cells(j, 1).Resize(Cc).Value = MyV
　 Next i
　 With Sheets("Sheet2")
　　　ErW = .Range("A65536").End(xlUp).Row
　　　With .Range("A1:A" & ErW)
　　　　 .Sort Key1:=.Cells(1), Order1:=xlDescending, _
　　　　 Header:=xlNo, Orientation:=xlSortColumns
　　　　 .Offset(, 255).Formula = "=COUNTIF(Sheet1!" & Ad & ",$A1)"
　　　End With
　　　i = 1: j = 0
　　　Do
　　　　 Cnt = .Cells(i, 256).Value
　　　　 For j = 1 To Cnt
　　　　　　If j = 1 Then
　　　　　　　 Set FR = _
　　　　　　　 MyR.Find(.Cells(i, 1).Value, , xlValues, xlWhole)
　　　　　　Else
　　　　　　　 Set FR = _
　　　　　　　 MyR.Find(.Cells(i, 1).Value, FR, xlValues, xlWhole)
　　　　　　End If
　　　　　　.Cells(i, 1).Value = FR.Address(0, 0)
　　　　　　i = i + 1
　　　　 Next j
　　　　 Set FR = Nothing
　　　Loop While i <= ErW
　　　.Range("IV:IV").ClearContents: .Activate
　 End With
　 Set MyR = Nothing
End Sub

0 hits

▼

【45807】どのようにやるのでしょうか？ KAI 07/1/14(日) 22:07