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 質問
【45808】Re:どのようにやるのでしょうか? KAI 07/1/14(日) 22:10 発言
【45812】Re:どのようにやるのでしょうか? Kein 07/1/14(日) 23:42 回答
【45810】Re:どのようにやるのでしょうか? ichinose 07/1/14(日) 22:56 発言
【45874】Re:どのようにやるのでしょうか? KAI 07/1/16(火) 20:51 お礼

36105 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free