VBAで重複するデータを検索し,一致するデータがある場合は,
その隣のセルを別シートにて横方向に表示させたいと思っています。
どのようにしたら,良ろしいでしょうか?
具体的には,下記のSheet1 のデータを元に,VBAでSheet2を作成したいと考えています。
<<Sheet1>>
社名 品名
-----+------+
A社 PC
A社 プリンタ
B社 モデム
B社 PC
A社 スキャナ
C社 PC
<<Sheet2>>
社名 品名1 品名2 品名3
-----+------+--------+--------+
A社 PC プリンタ スキャナ
B社 モデム PC
C社 PC
関連して・・・
・Sheet2の社名は重複表示させない
・品名1,品名2,品名3の順番は,Sheet1にて1行目から検索してヒットする順番で表示
・重複するデータがない場合(C社),そのまま社名と品名をSheet2に表示
以上,よろしくお願い致します。
A 回答 (4件)
- 最新から表示
- 回答順に表示
No.4
- 回答日時:
Excel の関数等不慣れなので、そういう人が考えたら・・・の例になるか?も
重複排除・・・ Dictionary を使ってしまいます。
今回の場合、社名がキーで品名が内容
社名は出現順、品名も出現順(ただし、重複する品名は覚えない)
以下の関数を標準モジュールに記述しておきます。
Public Sub CngShowPtn(rng As Range, toRng As Range)
Dim dic As Object
Dim v As Variant, vr As Variant
Dim bNxt As Boolean
Dim i As Long, iv As Long, ivmax As Long
Set dic = CreateObject("Scripting.Dictionary")
With rng
i = 1
While (.Offset(i) <> "")
bNxt = True
v = dic.Item(.Offset(i).Value)
If (Not IsArray(v)) Then
ReDim v(0)
Else
For Each vr In v
If (vr = .Offset(i, 1).Value) Then
bNxt = False
Exit For
End If
Next
If (bNxt) Then ReDim Preserve v(UBound(v) + 1)
End If
If (bNxt) Then
v(UBound(v)) = .Offset(i, 1).Value
dic.Item(.Offset(i).Value) = v
End If
i = i + 1
Wend
End With
If (dic.Count > 0) Then
With toRng
i = 1
ivmax = 0
For Each v In dic.Keys
vr = dic.Item(v)
iv = UBound(vr) + 1
If (iv > ivmax) Then ivmax = iv
.Offset(i) = v
.Offset(i, 1).Resize(, iv) = vr
i = i + 1
Next
.Offset(0) = rng
For i = 1 To ivmax
.Offset(0, i) = rng.Offset(0, 1) & i
Next
End With
End If
Set dic = Nothing
End Sub
使い方は、どこの表を、そして結果をどこに表示する
を Range で指定します。
以下を実行してみた結果は、添付図のようになります。
Public Sub test()
Call CngShowPtn(Range("A1"), Range("D2"))
Call CngShowPtn(Range("A9"), Range("D10"))
End Sub
また、シートを修飾して指定したりします。
例)
Call CngShowPtn(Worksheets("Sheet1").Range("A1") _
, Worksheets("Sheet2").Range("A1"))
No.2
- 回答日時:
簡単なものを作ってみました。
該当社名が一番最初に登場する行の右に品名を追加していき、最後に社名登場が2番目以降の不要な行を削除して形を整えています。
Sub Sample()
Dim nMax, nMatch, nCol, sString, i
'Sheet1からSheet2にコピー
Sheets("Sheet1").Cells.Copy
Sheets("Sheet2").Range("A1").Select
ActiveSheet.Paste
nMax = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To nMax 'データがあるのは2行目から
nMatch = WorksheetFunction.Match(Cells(i, 1), Range("A:A"), 0)
If nMatch <> i Then
'品名を右に表示
sString = sString & i & ":" & i & "," '不要行削除用
nCol = Cells(nMatch, 1).End(xlToRight).Column
Cells(nMatch, nCol + 1) = Cells(i, 2)
End If
Next i
'不要な行の削除
sString = Left(sString, Len(sString) - 1)
Range(sString).Delete Shift:=xlUp
End Sub
No.1
- 回答日時:
こんにちは。
技術的に簡易なものを選んで書いてみました。
VBAに慣れたら、配列とか外部オブジェクトとか使いたくなると思いますが、
そこまで望んでいるようには見受けられなかったので、易しい方法にします。
具体的なご要望あれば、一応お応えするつもりです。
指定が漏れている点、都合上、すべて可変にして書いています。
以下こちらで仮に設定したもの。
社名は、A列にある nKeyCol = 1
品名は、B列にある nField2Col = nKeyCol + 1
統合するデータの元の列は(B列に始まり)B列で終る nFieldsEndCol = nField2Col + 0
レコードの先頭行は3行め nTopRow = 3
Sheet2 のフィールド名を設定する記述は省きました。
Sub Re7799914cc()
Dim vTemp As Variant
Dim wshtP As Worksheet
Dim flgA() As Boolean
Dim nKeyCol As Long
Dim nField2Col As Long
Dim nFieldsEndCol As Long
Dim nTopRow As Long
Dim nBottomRow As Long
Dim nC As Long
Dim nR As Long
Dim i As Long
Dim j As Long
Dim k As Long
Set wshtP = Sheets("Sheet2") ' ◆指定
nKeyCol = 1 ' ◆指定
nField2Col = nKeyCol + 1 ' 2 ' ◆指定
nFieldsEndCol = nField2Col + 0 ' 2 ' ◆指定
With Sheets("Sheet1") ' ◆指定
nTopRow = 3 ' ◆指定
nBottomRow = .Cells(Rows.Count, nKeyCol).End(xlUp).Row
ReDim flgA(nTopRow To nBottomRow) As Boolean
nR = nTopRow - 1
For i = nTopRow To nBottomRow
If Not flgA(i) Then
nR = nR + 1
vTemp = .Cells(i, nKeyCol).Value
wshtP.Cells(nR, nKeyCol).Value = vTemp
nC = nField2Col - 1
For k = nField2Col To nFieldsEndCol
nC = nC + 1
wshtP.Cells(nR, nC).Value = .Cells(i, k).Value
Next k
For j = i + 1 To nBottomRow
If Not flgA(j) Then
If .Cells(j, nKeyCol).Value = vTemp Then
flgA(j) = True
For k = nField2Col To nFieldsEndCol
nC = nC + 1
wshtP.Cells(nR, nC).Value = .Cells(j, k).Value
Next k
End If
End If
Next j
End If
Next i
End With
Set wshtP = Nothing
Erase flgA
End Sub
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) フォルダ内のエクセルファイルを開かずにデータ採取する関数式 2 2022/12/22 22:15
- Excel(エクセル) SUMIFSと日付変換 10 2023/04/16 15:38
- Visual Basic(VBA) VBA For Each 〜 複数条件について 3 2022/10/20 20:05
- Excel(エクセル) エクセルでフィルタ後の列の重複を回避したい 6 2022/10/13 12:50
- その他(買い物・ショッピング) JANコードの登録について 1 2022/07/23 14:19
- Excel(エクセル) 重複データの抽出について 2 2023/07/21 14:52
- その他(Microsoft Office) 従業員増減対応で当番種類の増減対応な当番表 21 2022/07/19 07:30
- Excel(エクセル) ExcelのVLOOKUP関数 7 2022/08/23 06:46
- Excel(エクセル) ピボットテーブルの表示変更の仕方 初心者なので、的外れな質問だったらすみません 受注日ごとに商品名と 1 2022/04/26 23:23
- Excel(エクセル) excelで検索した商品の画像(ネットワーク上の)を表示させたい。 3 2023/06/28 00:32
関連するカテゴリからQ&Aを探す
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
vbsからのExcelアドインのカス...
-
ExcelのVBAコードについて教え...
-
Geogebraの操作方法について
-
VBA一覧取得 再投稿
-
VBA指定行削除
-
【ExcelVBA】値を変更しながら...
-
VBA 複数のエクセルから一つの...
-
VBAで大量のファイルをシート名...
-
Vba 実数および実数タイプの変...
-
Excelのマクロについて教えてく...
-
VBA レジストリの値の読み方に...
-
VBAで各列の"+"と"o"の合計数を...
-
Excel VBAで値を変えながら、pd...
-
VB.NETでボタンのクリックイベ...
-
指定した条件で行セルを非表示...
-
エクセルVBAについて
-
【マクロ】1つのマクロの中に...
-
VBA ユーザーフォーム ボタンク...
-
エクセルについて
-
ExcelのVBAコードについて教え...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
複数のデータテーブルのデータ...
-
accessvbaで内容を結合して保存
-
VB6のオラクルのバインド変数
-
PostgreSQLでサブクエリーをJOI...
-
oo4oを使ったOracleへのデータ...
-
ExcelVBAで重複するデータを表...
-
SQLローダーCSV取込で、囲み文...
-
単一グループのグループ関数で...
-
select文の実行結果に空白行を...
-
テーブルの最後(最新)のレコー...
-
count関数の値をwhere句で使用...
-
【PL/SQL】FROM区に変数を使う方法
-
AccessのSQL文で1件のみヒット...
-
レコードの登録順がおかしい
-
SELECT FOR UPDATE で該当レコ...
-
複数のテーブルから値を合計出...
-
where句中のtrim関数について
-
2つの列が同じ値の行を取得するSQL
-
並べ替えについて
-
Oracleで「文字が無効です」の...
おすすめ情報