Excelで大量のデータ処理をしなくてはならないのですが、以下の処理をExcel VBAで自動処理できないでしょうか?どなたかお知恵をお貸しください。
別シートに参照リストと未完成リストがあります。参照リストのA列のデータの並びと未完成リストのA列の並びを同じくして、未完成リストを完成させます。参照リストのA列の並びはこんな風です。1 2 3 3 5 6 7 8 8 10 ・・・(データは昇順ですが必ずしも連番ではなく、同じデータが並ぶこともあります。) そして未完成リストの方は、1 2 3 4 5 7 8 10 ・・・といった風です。未完成リストのA列は1 2 3 3 4 5 7 8 8 10・・・という風にしたいのです。つまり参照リストにあっても、未完成リストにないデータは無視します。(上の例では、6です。)参照リストになくて、未完成リストにあるデータはそのまま残します。(上の例では、4です。)両方に共通のデータで参照リストのようにデータが重複しているときは、未完成リストの方に重複している分だけ行を挿入し、上のデータをコピーします。(上の例では、3と8です。)この処理を例えば、それぞれのA列を比較し、お互い共通していないデータ行をそれぞれのリスト上で不可視にし、そのあと、参照リストのA列のデータを参考に重複してるデータを見つけたら、未完成リストの方に重複している分だけ自動に行を挿入し、上のデータをコピーして、参照リストと未完成リストの共通のデータを同じならびにしたいのです。(このあと、参照リストのB,C,Dのデータを未完成リストにコピーするので、未完成リストにしかないA列のデータは、不可視にしておいて、B,C,Dのデータをコピーするときに行がずれないようにしたいのです。)
以上(1)、(2)の処理を自動にさせるためのVBAが分かる方がいらっしゃいましたら、是非ご教授お願いいたします。

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

A 回答 (5件)

充実した昼休みでした!



***追加A*** とコメントがある行はSheet4作成用です。
***追加B*** はSheet1で無視したデータの先頭セルを赤にします。(記入されていた、未完成リストNo.1上でこれらのデータに赤い色をつける・・・は参照リストを対象にしました)
***追加AB*** は両方に必要な行です。コメント行もありますが。
前回は未完成リストより大きい番号の参照リストデータは無視していましたが、処理対象とするためWhile、Wendを追加しています。
試して見て下さい。うまくいくといいですね。では。

Public Sub KanseiList()
Dim rg1, rg2, rg3 As Range '基準とするセル
Dim rg4 As Range '基準とするセル ***追加A***
Dim cot1 As Long '参照リストカウンタ
Dim cot2 As Long '未完成リストカウンタ
Dim cot3 As Long '完成リストカウンタ
Dim cot4 As Long '無視リストカウンタ ***追加A***
'
Const copyCol = 3 'コピーする列数(0から)
Dim cl As Integer '列カウンタ
'
Set rg1 = Worksheets("Sheet1").Range("A1")
Set rg2 = Worksheets("Sheet2").Range("A1")
Set rg3 = Worksheets("Sheet3").Range("A1")
Set rg4 = Worksheets("Sheet4").Range("A1") '***追加A***
Worksheets("Sheet3").UsedRange.Clear
Worksheets("Sheet4").UsedRange.Clear '***追加A***
'
'前回赤にしたセルを元に戻しておく(再処理への備え) '***追加B***
Worksheets("Sheet1").Range("A:A").Interior.ColorIndex = xlNone '***追加B***
'
With rg2
While .Offset(cot2, 0) <> ""
Select Case True
Case .Offset(cot2, 0) = rg1.Offset(cot1, 0)
'参照リストと未完成リストが一致
While .Offset(cot2, 0) = rg1.Offset(cot1, 0)
For cl = 0 To copyCol
'参照リストのAからD列をコピーする
rg3.Offset(cot3, cl) = rg1.Offset(cot1, cl)
Next
cot1 = cot1 + 1 '参照リストを更に調べる
cot3 = cot3 + 1
Wend
cot2 = cot2 + 1
Case rg1.Offset(cot1, 0) <> "" And .Offset(cot2, 0) < rg1.Offset(cot1, 0)
'未完成リストしかない(参照リストはある)
While rg2.Offset(cot2, 0) <> "" And .Offset(cot2, 0) < rg1.Offset(cot1, 0)
rg3.Offset(cot3, 0) = .Offset(cot2, 0)
cot2 = cot2 + 1 '未完成リストを更に調べる
cot3 = cot3 + 1
Wend
Case rg1.Offset(cot1, 0) = ""
'未完成リストしかない(参照リストがない)
rg3.Offset(cot3, 0) = .Offset(cot2, 0)
cot2 = cot2 + 1
cot3 = cot3 + 1
Case .Offset(cot2, 0) > rg1.Offset(cot1, 0)
'参照リストしかない
For cl = 0 To copyCol '***追加A***
rg4.Offset(cot4, cl) = rg1.Offset(cot1, cl) '***追加A***
Next '***追加A***
'色(赤色=3)をつける ***追加B***
rg1.Offset(cot1, 0).Interior.ColorIndex = 3 '***追加B***
cot4 = cot4 + 1 '***追加A***
cot1 = cot1 + 1
End Select
Wend
'参照リストにまだデータがある場合(基準とした未完成リストはデータがなくなった) ***追加AB***
While rg1.Offset(cot1, 0) <> "" '***追加AB***
For cl = 0 To copyCol '***追加A***
rg4.Offset(cot4, cl) = rg1.Offset(cot1, cl) '***追加A***
Next '***追加A***
'色(赤色=3)をつける ***追加B***
rg1.Offset(cot1, 0).Interior.ColorIndex = 3 '***追加B***
cot4 = cot4 + 1 '***追加AB***
cot1 = cot1 + 1 '***追加AB***
Wend '***追加AB***
End With
End Sub
    • good
    • 0
この回答へのお礼

nishi6さん、お昼休みの貴重なお時間を割いてまで、私どものわがままな申し出を聞いてくださり、何とお礼を申し上げればよいか分かりません。しかも2通りのプログラムをこんな短時間で作られてしまうなんて、社員一同驚愕しております。先にご回答くださったapril21さんもnishi6さんも何て素晴らしい技術をお持ちなんでしょう!!うらやましい限りでございます。このプログラムはまさに鬼に金棒です。本当に何から何までお世話になり、ありがとうございました。今回のことで私は真剣にプログラミングに取り組んでみようと強く思うようになりました。nishi6さんもapril21さんも私に新たな分野に挑戦するきっかけをくださいました。このことは私の人生にとって大きな意味を持つように思います。昼間nishi6さんのご回答を会社で読んだのですが、午後私は出かける予定があり、プログラムの実行が出来ませんでしたので、明日早速やってみようと思っております。とってもわくわくしております。本当にどうもありがとうございました。

お礼日時:2001/04/26 00:56

sheet1のデータ、sheet2のデータ、sheet3のデータA列をそのまま使いたいのであれば下記のように書き換えてsheet4のA列に



=Sheet2!A1&"は未完成リストで"&COUNTIF(参照リスト,Sheet2!A1)&"件"&IF(COUNTIF(参照リスト,Sheet2!A1)=0,"シート2のみ","")

適当に変更してください。
    • good
    • 0

>どのデータが無視されたものなのか後で分かるように



nishi6さんが忙しい間、下記数式でどのデータが無視されたものなのか調べてみては?

A列に参照リスト(データの範囲に参照リストと名前を定義します)
B列に未完成リスト(データの範囲に未完成リストと名前を定義します)
名前の定義の方法は「Excel VBAでデータを自動処理したい」に書いたので省きます。

■C1など適当なセルに↓の数式をコピーして貼り付けます。
貼り付けたものをコピーしてB列と同数のセルを選択して貼り付けます。

=B1&"は未完成リストで "&COUNTIF(参照リスト,B1)&"件"&IF(COUNTIF(参照リスト,B1)=0,"Bデータのみ","")

■↑と同じく貼り付け
=A1&"は参照リストで "&COUNTIF(未完成リスト,A1)&"件"&IF(COUNTIF(未完成リスト,A1)=0,"Aデータのみ","")

↑の数式で「4は未完成リストで0件Bデータのみ」 「6は参照リストで0件Aデータのみ」というように表示されるばすです。

◎ここからコピーして直貼りするとセルの高さが変になるのでメモ帳とかに貼り付けてコピーしなおしてセルに。
nishi6さん(。・_・。)ノがんばってねぇ~♪
慣れなれしいすぎ バキッ!☆/(x_x)ごめ
    • good
    • 0
この回答へのお礼

april21さん、前回の質問に引き続きこちらの方もご回答くださりありがとうございます。数式だけでもこのようなことが出来るのですね。ご参考にさせていただきます。

お礼日時:2001/04/26 00:21

過分なお言葉恐縮しています。

皆さんのお役に立ててうれしく思います。追記の件ですが了解しました。何行か追加すれば可能と思います。ただ、明日(25日)はサボリの時間がもてそうにないので1日程度お待ちください。では皆さんがんばって下さい。
    • good
    • 0
この回答へのお礼

nishi6さん、本当ですか?お忙しい中、お引き受けくださるとは!!前回のご回答に対するお礼を申し上げたことで、かえってnishi6さんに、余計な負担をおかけしてしまったようで恐縮しております。申し訳ありません。本当にお時間があるとき、気が向いたときで結構なのですよ。どうぞ無理をしないでくださいませ。

お礼日時:2001/04/25 23:29

何度か読んでやりたいこと(かな?)を作ってみました。

主旨を汲んでいなければお許しを。
参照リスト、未完成リスト、未完成リストの完成版が必要とお思いますので、それぞれSheet1,Sheet2,Sheet3に
対応して作りました。また、未完成リストの完成後フィルタを使ったりしてのコピー作業があるようなのでそれも組み込んでみました。コピーしたい列数-1をcopyColにセットします。私見ですがVBAで対応する場合は手作業を極力排除した方がいいと思います。質問ではA列の最後がどのようになっているか想像できませんでしたので、参照リスト個数>=<未完成リスト個数の3パターンに対応しています。(つもりです)


Public Sub KanseiList()
Dim rg1, rg2, rg3 As Range '基準とするセル
Dim cot1 As Long '参照リストカウンタ
Dim cot2 As Long '未完成リストカウンタ
Dim cot3 As Long '完成リストカウンタ
'
Const copyCol = 3 'コピーする列数(0から)
Dim cl As Integer '列カウンタ
'
Set rg1 = Worksheets("Sheet1").Range("A1") '参照リスト
Set rg2 = Worksheets("Sheet2").Range("A1") '未完成リスト
Set rg3 = Worksheets("Sheet3").Range("A1") '未完成リスト完成版
Worksheets("Sheet3").UsedRange.Clear
'
With rg2
'未完成リストを順に調べる
While .Offset(cot2, 0) <> ""
Select Case True
Case .Offset(cot2, 0) = rg1.Offset(cot1, 0)
'参照リストと未完成リストが一致
While .Offset(cot2, 0) = rg1.Offset(cot1, 0)
For cl = 0 To copyCol
'参照リストのAからD列をコピーする
rg3.Offset(cot3, cl) = rg1.Offset(cot1, cl)
Next
cot1 = cot1 + 1 '参照リストを更に調べる
cot3 = cot3 + 1
Wend
cot2 = cot2 + 1
Case rg1.Offset(cot1, 0) <> "" And .Offset(cot2, 0) < rg1.Offset(cot1, 0)
'未完成リストしかない(参照リストはある)
While rg2.Offset(cot2, 0) <> "" And .Offset(cot2, 0) < rg1.Offset(cot1, 0)
rg3.Offset(cot3, 0) = .Offset(cot2, 0)
cot2 = cot2 + 1 '未完成リストを更に調べる
cot3 = cot3 + 1
Wend
Case rg1.Offset(cot1, 0) = ""
'未完成リストしかない(参照リストがない)
rg3.Offset(cot3, 0) = .Offset(cot2, 0)
cot2 = cot2 + 1
cot3 = cot3 + 1
Case .Offset(cot2, 0) > rg1.Offset(cot1, 0)
'参照リストしかない
cot1 = cot1 + 1
End Select
Wend
End With
End Sub
    • good
    • 0
この回答へのお礼

nishi6さん、早々のご回答ありがとうございます。早速やってみました。大成功でした。会社の皆で大喝采でした。本当にありがとうございます。今日は会社の仲間たちの顔が皆晴れやかで社内がパッと明るくなりました。ところでnishi6さん、ご相談のですが、こんなすばらしいプログラムを提供していただいて、恐縮なのですが、このプログラムに以下の機能を追加することは可能でしょうか?参照リスト(sheet1のデータ)にあって、未完成リストNo.1(sheet2のデータ)に無いデータは、未完成リスト完成版(sheet3)には反映されず無視されますよね。実はこの無視されたデータは後で、別の未完成リストNo.2と照し合せる必要があるのです。そこで、どのデータが無視されたものなのか後で分かるように,未完成リストNo.1上でこれらのデータに赤い色をつけるとか、またこのデータだけをsheet4に抽出する等(どちらか1つでいいのですが・・・)出来ますでしょうか?これが出来ると本当に鬼に金棒なのですが・・・。でもこのプログラムでも私たちにとっては本当に大助かりでございますので、もしnishi6さんが気が向いたら、ご返答いただければ・・・と図々しくもお願いした次第です。でもどうか気になさらないでくださいませ。ご迷惑でしたら、どうぞ無視されて結構です。まずは社員一同お礼心よりお礼申し上げます。では・・・。

お礼日時:2001/04/24 23:24

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

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

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

QA列とB列の重複を抽出したいのですがA列とB列の値は一部だけ同じ文字です。ご教示お願いします。

エクセル初心者です。重複を見つけるのが仕事です。いろいろやってみたのですがうまくできません。
お知恵をお貸しください。

A列には企業名が入力されています。
B列にも企業名が入力されていますが全く同じ文字ではないのです。

たとえばこういうことです。
A1 (有)雪見酒      B1  雪見
A2 株式会社豪雪地帯   B2 (株)豪雪地帯
A3 ゆきかき本舗     B3 (有)ゆきかき本舗

A列にある企業名とB列にある企業名が同じであればセルを塗りつぶすか○を表示させるように
したいのです。
重複を見つけるのが目的なので、ほかの方法でもかまいません。
すみません、A列のセルとB列のセルが全く同じ名前ならば重複が見つけられたのですが
ここから先がどうしてもわからないのです。。。
申し訳ありませんがどうか教えてください。。。

Aベストアンサー

No4です。以下のマクロを標準モジュールへ登録してください。
--------------------------------------------------
Option Explicit
Public Sub 重複チェック()
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim row1 As Long
Dim row2 As Long
Dim nameT1() As String
Dim nameT2() As String
Dim t1, t2 As Variant
t1 = Time
maxrow1 = Cells(Rows.Count, "A").End(xlUp).row '最大行取得
maxrow2 = Cells(Rows.Count, "B").End(xlUp).row '最大行取得
ReDim nameT1(maxrow1)
ReDim nameT2(maxrow2)
Range("C1:" & "D" & maxrow2).Value = ""
Call makeTable(nameT1, "A", maxrow1)
Call makeTable(nameT2, "B", maxrow2)
For row1 = 1 To maxrow1
For row2 = 1 To maxrow2
If Cells(row2, "C") = "" Then
If Mymatch(nameT1(row1), nameT2(row2)) = True Then
Cells(row2, "C").Value = "○"
Cells(row2, "D").Value = row1
End If
End If
Next
Next
t2 = Time
MsgBox ("チェック完了 処理時間=" & Minute(t2 - t1) & "分" & Second(t2 - t1) & "秒")
End Sub
'余分な文字を削除した結果をテーブルに格納する
Private Sub makeTable(ByRef nameT() As String, ByVal col As String, ByVal maxrow As Long)
Dim row As Long
Dim ary As Variant
Dim name As String
Dim i As Long
ary = Array("㈱", "(株)", "株式", "(有)", "有限", "会社")
For row = 1 To maxrow
name = Cells(row, col).Value
For i = 0 To UBound(ary)
name = Replace(name, ary(i), "")
Next
nameT(row) = name
Next
End Sub
'企業名が一致かどうか判定する
Private Function Mymatch(ByVal name1 As String, ByVal name2 As String) As Boolean
Mymatch = False
Dim pos As Variant
pos = InStr(1, name1, name2, vbTextCompare)
If pos > 0 Then Mymatch = True
End Function
-----------------------------------------------------
一致の精度が悪ければその旨補足してください。
(一致すべきものが一致しない、一致してはいけないものが一致している)
100%解決できる保証はありませんが、多少のチューニングは行います。

No4です。以下のマクロを標準モジュールへ登録してください。
--------------------------------------------------
Option Explicit
Public Sub 重複チェック()
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim row1 As Long
Dim row2 As Long
Dim nameT1() As String
Dim nameT2() As String
Dim t1, t2 As Variant
t1 = Time
maxrow1 = Cells(Rows.Count, "A").End(xlUp).row '最大行取得
maxrow2 = Cells(Rows.Count, "B").End(xlUp).row '最大行取得
ReDim ...続きを読む

QExcel2013 VBA A列とB列の文字をA列とB列とC列に移動させる方法

A列とB列に文字が入っているのですが、下記のようにA列とB列とC列に文字を移動させたいです。
(A列の数字は必ず奇数のA列に入っています。)
VBAのコードを教えて下さい。

例えば
A1 1  B1 cat
A2 空白 B2 猫
A3 空白 B3 dog
A4 空白 B4 犬
A5 2  B5 whale
A6 空白 B6 クジラ
A7 3  B7 rabbit
A8 空白 B8 ウサギ

とデータがある場合

A1 1  B1 cat  C1 猫
A2 空白 B2 dog  C2 犬
A3 2  B3 whale  C3 クジラ
A4 3  B4 rabbit C4 ウサギ

としたいです。

実際、データは、A5196まであります。

Aベストアンサー

No.1です。

>実際、データは、A5196まであります。

前回のコードは一つずつカット&ペーストしていますので
かなりの時間を要すると思います。
↓のコードに変更してみてください。

Sub Sample2()
Dim lastRow As Long
lastRow = Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
With Range(Cells(1, "C"), Cells(lastRow, "C"))
.Formula = "=IF(MOD(ROW(),2)=1,B2,"""")"
.Value = .Value
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

少しは短縮できると思います。m(_ _)m

No.1です。

>実際、データは、A5196まであります。

前回のコードは一つずつカット&ペーストしていますので
かなりの時間を要すると思います。
↓のコードに変更してみてください。

Sub Sample2()
Dim lastRow As Long
lastRow = Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
With Range(Cells(1, "C"), Cells(lastRow, "C"))
.Formula = "=IF(MOD(ROW(),2)=1,B2,"""")"
.Value = .Value
.SpecialCells(xlCellTypeB...続きを読む

Qエクセルで、A列に日付をB列に曜日、C列からF列までにデータを入れるよ

エクセルで、A列に日付をB列に曜日、C列からF列までにデータを入れるように作成しています。
条件付書式で土日祭日の場合はC列からF列に色を表示させています。
この色付セル(土日祭日)の場合にはデータ入力が無いので自動で0を表示させ、なおかつデータ入力が出来ないようにしたいのですが、そのようなことは出来るでしょうか。エクセルは2003を使ってます。

Aベストアンサー

C2セルに以下の数式を入力します。

=IF(AND($A2<>"",WEEKDAY($A2,2)>5),0,"")

同様にC2セルに以下の入力規則を設定します。

「データ」「入力規則」で「ユーザー設定」にして数式欄に以下の式を入力します。

=WEEKDAY($A2,2)<6

最後にC2セルを右方向および下方向にオートフィルします。

QエクセルでA列B列C列の重複するレコードのみを表示

エクセルのA列とB列とC列で重複するレコードのみを抽出して別の列に表示させたい。

エクセルのA列とB列とC列にそれぞれ1000行くらいのデータがあります。
それぞれの列内には重複レコードがあります。

この条件の中で

「A列とB列とC列に重複するデータすべて」

を抽出したいのですが、どんな方法がありますか。
抽出されたデータで重複レコードの場合は1件のみで表示したいです。

よろしくお願いします。


  A   B   C   抽出 
1-001-002--002--002
2-002-002--005--007
3-003-007--007--008
4-007-008--008--011
5-008-008--010
6-008-010--011
7-011-011--012
8-013-014--013

Aベストアンサー

式が複雑になるということはそれだけ分かりにくく、計算が重くなるということです。出来るだけ作業列を使ってわかりやすく処理することが肝要と考えます。
例えばA,B,C列の2行目からお示しのようなデータがあるとします。
D2セルには次の式を入力して下方にオートフィルドラッグします。

=IF(AND(COUNTIF(A$2:A2,A2)=1,COUNTIF(B:B,A2)>0,COUNTIF(C:C,A2)>0),MAX(D$1:D1)+1,"")

D列にはA,B,C列に共通して含まれるデータがあれば上から順に番号が付けられます。その際にもしもA列でダブったデータがある場合には最初に出てきたデータに番号が振られます。

お求めのデータはE列に並べるとしてE2セルには次の式を入力して下方にオートフィルドラッグします。

=IF(ROW(A1)>MAX(D:D),"",INDEX(A:A,MATCH(ROW(A1),D:D,0)))

D列が目障りでしたら列を非表示にすればよいでしょう。

Qエクセルの関数を教えて下さい。 例 シート3 11月の売上集計 A 列 B列 C列 D列 1行 い

エクセルの関数を教えて下さい。

例 シート3 11月の売上集計
A 列 B列 C列 D列
1行 い ろ は
2行 りんご 3 2 4‥
3行 累計 15 12 13‥
4行 みかん 2 5 6‥
5行 累計 12 14 16‥
と売上の集計が続いています。
この時、2行目と4行目は手入力してます。
B3は=B2+10月シートB3となります。
C3はC2+10月シートC3となります。
5行目も同様です。
このシートをコピーして12月分を作った時、
B3は=B2+10月シートB3の10月を11月に
変更してます。
自動的に変更できる方法はないですか❓

Aベストアンサー

11月の
>シートをコピーして12月分を作った時、
>B3は=B2+10月シートB3の10月を11月に
>変更してます。
>自動的に変更できる方法はないですか❓
…と言う事ですか?
ならば月の数字をいじれば良いだけですので、CELL関数でシート名を取得して、それを加工しましょう。

 =CELL("filename",A1)
これで、このCELL関数が使われたシート名を含んだ文字列を取得できます。
 C:\Users\あさご\Documents\Excel_file\[売り上げとか.xlsx]12月の売上集計
のような値が返ってきますので、ファイル名の後ろにある「 ] 」の位置をFIND関数で見つけて、その次の文字から最後の文字までをシート名としてMID関数などで切り出し、
”月の売上集計”をSUBSTITUTE関数で削除する(空欄に置き換える)か、得られたシート名の先頭から「月」の文字の前の文字までを別途切り出す。
これで月の数字の部分を得ることができます。
あとはこの数字を足したり引いたりしてINDIRECT関数に入れて参照したいシート名にすればよいです。
1月には12月のシートを参照したいという事になるでしょうから、そのあたりも考慮して作りましょう。
(MOD関数を使うと良いかもしれない)

11月の
>シートをコピーして12月分を作った時、
>B3は=B2+10月シートB3の10月を11月に
>変更してます。
>自動的に変更できる方法はないですか❓
…と言う事ですか?
ならば月の数字をいじれば良いだけですので、CELL関数でシート名を取得して、それを加工しましょう。

 =CELL("filename",A1)
これで、このCELL関数が使われたシート名を含んだ文字列を取得できます。
 C:\Users\あさご\Documents\Excel_file\[売り上げとか.xlsx]12月の売上集計
のような値が返ってきますので、ファイル名の後ろ...続きを読む


人気Q&Aランキング

おすすめ情報