出産前後の痔にはご注意!

下記のようなExcelの表があります。

コードA コードB 本文 言語 図面種類 図面名
 1    a   123  J   tif  a.tif
 2     b   456  E   pdf  b.pdf
 3    c   789   J  gif   c.gif
 4    a   145   E  eps   a_1.eps
 5    d   235   E  tif   d.tif
 6    c   467   E  pdf   c_1.pdf
 7    a   345   J  gif   a_2.gif

これを、コードBが重複する行があれば、行の中の言語、図面種類、図面名をコードAが一番早い数字の最終列に移動するVBAを作成したいと思っています。

コードA コードB 本文 言語 図面種類 図面名 言語 図面種類 図面名 言語 図面種類 図面名
 1    a   123  J   tif   a.tif  E  eps  a_1.eps J  gif   a_2.gif
 2     b   456  E   pdf  b.pdf
 3    c   789   J  gif   c.gif  E  pdf   c_1.pdf
 5    d   235   E  tif   d.tif
 7    a   345   J  gif   a_2.gif

検索して下記のページを見つけ、いろいろ調べて変更してみたのですが、Cellsの指定方法がよくわからず、先に進めません。
どのようにしたら上記の結果を表示できるか、お助け頂けないでしょうか?
http://okwave.jp/qa552017.html

Sub transform()

Dim x As Integer
Dim y As Integer

y = 3 '先頭のデータの行

Do Until Cells(y + 1, 2).Value = "" '重複セルの列の値が空になるまでループする

y = y + 1

If Cells(y, 2).Value = Cells(y - 1, 2).Value Then
x = Cells(y - 1, 2).End(xlToRight).Column + 1 '最終列の隣に追加
Cells(y - 1, x).Value = Cells(y, 2).Value
Cells(y, 2).EntireRow.Delete
y = y - 1

End If

Loop

End Sub

このQ&Aに関連する最新のQ&A

A 回答 (5件)

7行目は削除されるでいいのかな?


Sub sample()
Dim r As Long
r = 2
Do While Cells(r, 2) <> ""
If WorksheetFunction.CountIf(Range("B2").Resize(r - 1, 1), Cells(r, 2)) > 1 Then
Cells(r, 4).Resize(1, 3).Copy Destination:=Cells(Range("B1").Resize(r, 1).Find(Cells(r, 2)).Row, Columns.Count).End(xlToLeft).Offset(0, 1)
Rows(r).Delete
Else
r = r + 1
End If
Loop
End Sub
    • good
    • 0
この回答へのお礼

回答ありがとうございます!
7行目は削除されるで問題ありません!
スクリプトを実行してみたら、見事できました。
この2日くらいずっと悩んでいたので、エラーなく動作をしているのを見て感動してしまいました。
またスクリプトの中のRangeオブジェクト、Copy Destinationなどを検索していたら、とても参考になるサイトも見つけられました。
とても助かりました。本当に、ありがとうございます!!

お礼日時:2008/07/17 10:47

Sub try()


Dim Dic As Object
Dim i As Long, j As Long
Dim k As Long, m As Integer, Max_col As Integer
Dim v, vv

Set Dic = CreateObject("Scripting.Dictionary")

With Worksheets("Sheet1")
v = .Range(.[A3], .Cells(Rows.Count, 1).End(xlUp).Resize(, 6)).Value
End With

ReDim vv(1 To UBound(v, 1), 1 To 256)
For k = 1 To UBound(v, 1)
If Not Dic.Exists(v(k, 2)) Then
i = i + 1
For m = 1 To 6
vv(i, m) = v(k, m)
Next
Dic(v(k, 2)) = Array(i, 6)
Else
For m = 1 To 3
vv(Dic(v(k, 2))(0), Dic(v(k, 2))(1) + m) = v(k, m + 3)
Next
Dic(v(k, 2)) = Array(Dic(v(k, 2))(0), Dic(v(k, 2))(1) + 3)
If Max_col < Dic(v(k, 2))(1) Then Max_col = Dic(v(k, 2))(1)
End If
Next

With Worksheets("Sheet2")
.Cells.ClearContents
.Range("A3").Resize(Dic.Count, UBound(vv, 2)).Value = vv
.Range("A2").Resize(, 6).Value = Worksheets("Sheet1").Range("A2").Resize(, 6).Value
.Range("D2").Resize(, 3).AutoFill Destination:=Range("D2").Resize(, Max_col - 3),
Type:=xlFillDefault
End With
Erase v, vv
Set Dic = Nothing
End Sub
    • good
    • 0
この回答へのお礼

回答ありがとうございます!
こちらは新しいワークシートにデータを移行する方法ですね。
こちらもとても参考になりました。
ありがとうございます!!

お礼日時:2008/07/23 12:57

問題は>コードBが重複する行があれば


の重複をどういう風にVBAコードでに検出するかにある。
この点がポイントなのに、検討した形跡が見られない。確かにプログラムの多数の経験がなければ、1-2時間考えても、そう浮かんでこないでしょうが。
これも他人の回答を見習うより他無いのだろう。
ーーー
(1)ソート法
(2)カウント法
(3)Find法
など思い浮かぶ。
(1)はB列でソートすると例えばaの行は固まる。その状態を使う。
ロジックは一番簡単になるでしょう。
(3)はB列でaを見つけるFindメソッドを発行し、見つかれば所定の
処理をし、見つかった次の行以下を対象に、aを見つけるFindメソッドを発行し、最終まで繰り返す。ただ見つかった行をまた
検索しないような仕掛けが必要です。少し複雑。
==
例データ B1:C10
aX
sY
xV
cW
dZ
aT
dS
aR
fQ
cP
ーーー
コード
Sub test01()
d = Range("B65536").End(xlUp).Row
For i = 1 To d
x = Application.WorksheetFunction.CountIf(Range("B1:B" & i), Range("B" & i))
If x > 1 Then
' 重複行の下の行探知
y = Application.WorksheetFunction.Match(Range("B" & i), Range("B1:B100"), 0)
c = Range("az" & y).End(xlToLeft).Column '右端列の探知
Cells(y, c + 1) = Cells(i, "B").Offset(0, 1) '隣列データ
End If
Next i
'---重複行削除
For i = d To 1 Step -1
x = Application.WorksheetFunction.CountIf(Range("B1:B" & i), Range("B" & i))
If x > 1 Then
Cells(i, "B").EntireRow.Delete
End If
Next i
End Sub
上記はC列1列しか右へ累積していないので、質問のためには手直し必要。言語、図面種類、図面名の3列づつ(3列分)移す(累積する)ように手直しが必要。
ちょっと危ないロジックかなと思うので、ソート法を薦めます。
ーー
結果
B列  C列    D列   E列(C列以右列に累積)
aXTR
sY
xV
cWP
dZS
fQ
    • good
    • 0
この回答へのお礼

回答ありがとうございます!
ご指摘の通り、プログラムの経験がほとんどなく、VBAも今回が初めてと言っていいほどです。
Cellsの値を検討してみたのですが全くうまくいかず、結局元に戻して掲載しました…。
いろいろと考え方を提示くださってありがとうございます。
とても参考になりました。

お礼日時:2008/07/17 10:44

提示されたVBAを少し作り直してみました。



何かの参考になれば幸いです。

Sub transform()

Dim x As Integer
Dim y As Integer

y = 3 '先頭のデータの行

Do Until Cells(y + 1, 2).Value = "" '重複セルの列の値が空になるまでループする

If Cells(y, 2).Value = Cells(y + 1, 2).Value Then
x = Cells(y, 256).End(xlToLeft).Column + 1 '最終列の隣に追加
Cells(y, x) = Cells(y + 1, 2)
Cells(y + 1, 2).EntireRow.Delete
Else
y = y + 1
End If

Loop

End Sub
    • good
    • 0
この回答へのお礼

回答ありがとうございます!
試してみましたが、図面種類などは追加されず、右側に1つずつコードBが追加されたのみでした。
でも、考えて下さってありがとうございました!

お礼日時:2008/07/17 10:14

リンク先の回答の場合は、比較したいデータが並んでいる時には使えますが、


提示されている表の様子からだと、ちょっと違うように思います。

>コードBが重複する行があれば、行の中の言語、図面種類、図面名をコードAが一番早い数字の最終列に移動する
だとすると、
>7    a   345   J  gif   a_2.gif

>1    a   123  J   tif   a.tif  E  eps  a_1.eps J  gif   a_2.gif
ここに来るはずですが・・・?
間違えか、条件が別にあるのか、不明です。

あと、コードAは昇順に並んでいると言う事でしょうか?
    • good
    • 0
この回答へのお礼

回答ありがとうございます!
ご指摘の通り、7は消し忘れです。
混乱させてしまい申し訳ありません…。
コードAは昇順に並んでいます。

お礼日時:2008/07/17 10:02

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

QEXCELのVBAで、重複データを隣のセルへ移動したい

度々申し訳ありません。宜しくお願いします。
下記のように日付が重複し、データは重複していない表があります。

日付  機械
4/1   1
4/1   5
4/1   3
4/2   2
4/2   3

これを

日付  機械1 機械2 機械3
4/1   1    5    3
4/2   2    3

というようにしたい場合、どのように組んだらいいのでしょうか?
申し訳ありませんが、宜しくお願いします。

Aベストアンサー

データが
A列に日付
B列に機械
が入ってるものとして
2行目からデータが入っている場合、
下記で動くと思います。

Sub transform()
Dim x As Integer
Dim y As Integer

y = 2 '先頭のデータの行

Do Until Cells(y + 1, 1).Value = ""
y = y + 1
If Cells(y, 1).Value = Cells(y - 1, 1).Value Then
x = Cells(y - 1, 1).End(xlToRight).Column + 1
Cells(y - 1, x).Value = Cells(y, 2).Value
Cells(y, 2).EntireRow.Delete
y = y - 1
End If
Loop
End Sub


人気Q&Aランキング