VBAでの重複データの別シート表示について

VBAでの新規シート作成について


VBA初心者です。Excel2007、XPを使用しています。

シート1のA列からCP列まで、約1000行データがあります。
1行目は見出しです。

その中でCP列の値が同じ行のみ、
別シートの各位置、見出し行+最大10行としてに表示したいです。
最低でも同じ値が各2行はあります
ちなみにA列とCP列は同じ値なので、A列で判別しても問題ないです。

(例)
Sheet1
A... / CN / CO / CP
項目1... / 項目92 / 項目93 / 項目94
1111 / 品名1 / ○ / 1111
1111 / 品名2 / ○ / 1111
1222 / 品名3 / ○ / 1222
1222 / 品名4 / ○ / 1222
1222 / 品名2 / ○ / 1222
1333 / 品名3 / ○ / 1333
1333 / 品名4 / ○ / 1333


→Sheet2
AA... / DN / DO /DP.
項目1... / 項目92 / 項目93 / 項目94
1111 / 品名1 / ○ / 1111
1111 / 品名2 / ○ / 1111

AA53から
項目1... / 項目92 / 項目93 / 項目94
1222 / 品名3 / ○ / 1222
1222 / 品名4 / ○ / 1222
1222 / 品名2 / ○ / 1222

AA105から
1333 / 品名3 / ○ / 1333
1333 / 品名4 / ○ / 1333


といったように、52行ずつずらした位置に表示したいです。
A列からU列の間に明細を表示しており、
そちらに参照する行として、隣に表示を出来ればと思っております。

恐れ入りますが、ご教授頂けないでしょうか。
宜しくお願い致します。

No.4 ベストアンサー 回答者： 30246kiku 回答日時： 2015/09/19 07:18

＃３です

せっかくなので

> もし、切った行を次の塊としてコピーするのなら、
> 後半の方を優先するのなら、
> また、AA 以降をクリアしてから･･･とかなら

これ、変更量も多くないので盛り込んでみました


Public Sub Samp3()
   Dim dic As Object
   Dim ws As Worksheet
   Dim vA As Variant, v As Variant
   Dim sS As String
   Dim i As Long, j As Long
   Const CROWMAX As Long = 10

   Set dic = CreateObject("Scripting.Dictionary")

   Application.ScreenUpdating = False
   Set ws = Worksheets("Sheet2")
' ☆～ AA 以降クリアしないのなら以下をコメントに
   With ws
      .Cells(1, "AA").Value = 1
      .Range("AA1", .Cells.SpecialCells(xlCellTypeLastCell)).Clear
   End With
' ～☆

   With Worksheets("Sheet1")
      vA = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)).Value
      For i = 2 To UBound(vA) ' 前優先
'      For i = UBound(vA) To 2 Step -1 ' 後優先
         If (vA(i, 1) <> "") Then
            If (Not dic.Exists(vA(i, 1))) Then
               dic(vA(i, 1)) = "A1"
            End If
            dic(vA(i, 1)) = dic(vA(i, 1)) & "," & "A" & i
         End If
      Next

      j = 1
      For Each v In dic.Keys ' 前優先用
'      For Each v In mySort(dic.Keys) ' 後優先にしたらこっちを有効に
         sS = dic(v)
         While (Len(sS) > 0)
            vA = Split(sS, ",", CROWMAX + 2)
            sS = ""
            If (UBound(vA) > CROWMAX) Then
'' ★～ １０行で切って余ったものを次に・・・なら以下1行有効に
'               sS = vA(0) & "," & vA(CROWMAX + 1)
'' ～★
               ReDim Preserve vA(CROWMAX)
            End If
            Intersect(.Range(Join(vA, ",")).EntireRow _
               , .Range("A:CP")).Copy ws.Cells(j, "AA")
            j = j + 52
         Wend
      Next
   End With
   Application.ScreenUpdating = True

   Set dic = Nothing
End Sub


Private Function mySort(ByVal vA As Variant) As Variant
   Dim v As Variant
   Dim i As Long, j As Long

   For i = LBound(vA) To UBound(vA) - 1
      For j = i + 1 To UBound(vA)
         If (vA(i) > vA(j)) Then
            v = vA(i)
            vA(i) = vA(j)
            vA(j) = v
         End If
      Next
   Next
   mySort = vA
End Function

この回答へのお礼

ありがとうございます！
こちらも思った通りの動作で、また細かな変更も頂き、
誠にありがとうございます。

お礼日時：2015/09/25 17:47

No.3 回答者： 30246kiku 回答日時： 2015/09/19 03:44

＃１です

解釈抜け/読み飛ばしが結構あったみたいです

・Sheet2 はクリアしてはだめだったんですね
・１０行MAX だったんですね
・A へのコピーではなく、AA へのコピーだったんですね
・コピーする順は出現順？
項目１で並べ替えるのなら
　　　　For Each v In dic.Keys
↓
　　　　For Each v In mySort(dic.Keys)
なお、項目１はまとまっていなくても動きます

ギチギチ専用の記述はしていないので、
Samp1 からの記述変更はそう多くありません

※ １０行で切る場合、行後半のものが切れます
もし、切った行を次の塊としてコピーするのなら、
後半の方を優先するのなら、
また、AA 以降をクリアしてから･･･とかなら
記述を変更しますけど･･･


Public Sub Samp2()
　　Dim dic As Object
　　Dim ws As Worksheet
　　Dim vA As Variant, v As Variant
　　Dim i As Long, j As Long
　　Const CROWMAX As Long = 10

　　Set dic = CreateObject("Scripting.Dictionary")

　　Application.ScreenUpdating = False
　　Set ws = Worksheets("Sheet2")

　　With Worksheets("Sheet1")
　　　　vA = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)).Value
　　　　For i = 2 To UBound(vA)
　　　　　　If (vA(i, 1) <> "") Then
　　　　　　　　If (Not dic.Exists(vA(i, 1))) Then
　　　　　　　　　　dic(vA(i, 1)) = "A1"
　　　　　　　　End If
　　　　　　　　dic(vA(i, 1)) = dic(vA(i, 1)) & "," & "A" & i
　　　　　　End If
　　　　Next

　　　　j = 1
　　　　For Each v In dic.Keys
　　　　　　vA = Split(dic(v), ",")
　　　　　　If (UBound(vA) > CROWMAX) Then
　　　　　　　　ReDim Preserve vA(CROWMAX)
　　　　　　End If
　　　　　　Intersect(.Range(Join(vA, ",")).EntireRow _
　　　　　　　　, .Range("A:CP")).Copy ws.Cells(j, "AA")
　　　　　　j = j + 52
　　　　Next
　　End With
　　Application.ScreenUpdating = True

　　Set dic = Nothing
End Sub

No.2 回答者： WindFaller 回答日時： 2015/09/19 00:33

こんばんは。

>A列からU列の間に明細を表示しており、
>そちらに参照する行として、隣に表示を出来ればと思っております。
ということで、AA列に写すわけですね。
Sheet2 に既存のデータがすでにある上にこれを並べていくことになると、マクロ開始時にはSheet2 のデータは消せないということになりますでしょうか？

>別シートの各位置、見出し行+最大10行としてに表示したいです。
コピー行は、10行までということですね。

質問の内容の項目を逃さないつもりではいたのですが、もし見逃していたら、すみません。

'//
Sub DivideLines()
　Dim DiffArea As Range
　Dim EndCell As Range
　Dim LastCell As Range
　Dim Sh1 As Worksheet: Set Sh1 = Worksheets("Sheet1")
　Dim Sh2 As Worksheet: Set Sh2 = Worksheets("Sheet2")
　'' すでにデータがある場合は､この間は使用できない
'　If Application.CountA(Sh2.Cells) > 0 Then
'　　If MsgBox(Sh2.Name & "の全データを消しますがよろしいですか？", vbOKCancel) = vbOK Then
'　　　Sh2.Cells.Clear
'　　Else
'　　　Exit Sub
'　　End If
'　End If
　With Sh1
　　Application.ScreenUpdating = False
　　'------並べ替え----------すでに並べ替えが済んでいるなら、この間は不要
　　.Range("A1").CurrentRegion.Resize(, 94).Sort _
　　Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlYes
　　'------------------------
　　Dim Titles As Range: Set Titles = .Range("A1").Resize(, 94)
　　Dim FirstCell As Range: Set FirstCell = .Range("A2")
　　
　　Dim i: i = 1
　　Dim j
　　Set EndCell = .Cells(Rows.Count, 1).End(xlUp)
　　
　　Do
　　　On Error Resume Next
　　　Set DiffArea = .Range(FirstCell, EndCell).ColumnDifferences(FirstCell)
　　　If Err() <> 0 Then
　　　'10行以上はコピーしない
　　　j = Application.Min(EndCell.Row - FirstCell.Row + 1, 10)
　　　　Titles.Copy Sh2.Cells(i, "AA")
　　　　Range(FirstCell, EndCell).Resize(j, 94).Copy Sh2.Cells(i + 1, "AA")
　　　　Exit Do
　　　End If
　　　On Error GoTo 0
　　　Set LastCell = DiffArea.Cells(1).Offset(-1, 0)
　　　'10行以上はコピーしない
　　　j = Application.Min(LastCell.Row - FirstCell.Row + 1, 10)
　　　Titles.Copy Sh2.Cells(i, "AA")
　　　Range(FirstCell, LastCell).Resize(j, 94).Copy Sh2.Cells(i + 1, "AA")
　　　Set FirstCell = LastCell.Offset(1, 0)
　　　i = i + 52
　　Loop
　　Application.ScreenUpdating = True
　End With
　MsgBox "終了", vbInformation
End Sub
'///

この回答へのお礼

ありがとうございます！
イメージ通りの動作で感激いたしました。

お礼日時：2015/09/25 17:47

No.1 回答者： 30246kiku 回答日時： 2015/09/18 21:06

全くの未検証ですが、以下でどうなりますか

おかしかったらごめんなさい


Option Explicit

Public Sub Samp1()
　　Dim dic As Object
　　Dim ws As Worksheet
　　Dim vA As Variant, v As Variant
　　Dim i As Long, j As Long

　　Set dic = CreateObject("Scripting.Dictionary")

　　Application.ScreenUpdating = False
　　Set ws = Worksheets("Sheet2")
　　ws.Cells.Delete

　　With Worksheets("Sheet1")
　　　　vA = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)).Value
　　　　For i = 2 To UBound(vA)
　　　　　　If (vA(i, 1) <> "") Then
　　　　　　　　If (Not dic.Exists(vA(i, 1))) Then
　　　　　　　　　　dic(vA(i, 1)) = "A1"
　　　　　　　　End If
　　　　　　　　dic(vA(i, 1)) = dic(vA(i, 1)) & "," & "A" & i
　　　　　　End If
　　　　Next

　　　　j = 1
　　　　For Each v In mySort(dic.Keys)
　　　　　　.Range(dic(v)).EntireRow.Copy ws.Cells(j, "A")
　　　　　　j = j + 52
　　　　Next
　　End With
　　Application.ScreenUpdating = True

　　Set dic = Nothing
End Sub

Private Function mySort(ByVal vA As Variant) As Variant
　　Dim v As Variant
　　Dim i As Long, j As Long

　　For i = LBound(vA) To UBound(vA) - 1
　　　　For j = i + 1 To UBound(vA)
　　　　　　If (vA(i) > vA(j)) Then
　　　　　　　　v = vA(i)
　　　　　　　　vA(i) = vA(j)
　　　　　　　　vA(j) = v
　　　　　　End If
　　　　Next
　　Next
　　mySort = vA
End Function