ここから本文です

Excelで特定の文字の入ったセルの行数を順番にセルに表示していく事はできないでし...

アバター

ID非公開さん

2014/5/2715:05:54

Excelで特定の文字の入ったセルの行数を順番にセルに表示していく事はできないでしょうか?

Aに商品名、Bに会社名の入ったシートが有り、途中には空白行もあります。
これを会社名ごとにシート分けし、上から順番に詰めて表示させたいんです。
会社名の検索では一番最初に出てきたセルしか拾えないので、その会社名の入ったセルを数えさせて、2番目、3番目の行数を表示させるといったことが出来ないのかと試行錯誤していたのですが完全に行き詰まりました。

例はかなり簡略化してありますが実際はもう少しややこしいです。
毎回フィルタをかけてコピペするというのも考えたのですが関数で出来れば嬉しいです。

今までは会社名ごとのシートにその会社名が入った行だけを表示する関数を入力しマクロで空白行を削除するというやり方をしていたのですが元シートの行数が1000行ほど、会社名が20社ほどあり、そのやり方だと毎回20000行近い空白行を削除することになるので結構時間がかかります。

パッとコピペしてポンッとマクロのショートカットを押して出来上がり~といった感じにしたいのですが不可能でしょうか?

閲覧数:
409
回答数:
3
お礼:
100枚

違反報告

ベストアンサーに選ばれた回答

mit********さん

2014/5/2715:37:48

次のようにすればよいでしょう。
複雑な関数を使いますとデータが多くなればとたんに計算に負担がかかります。作業列を作って対応するのがお勧めです。
元の表がシート1に有るとしてA列からF列までの表で1行目には項目名が2行目から下方にデータが入力されているとします。
A1セルには商品名、B1セルには会社名の項目名が有るとします。
G2セルには次の式を入力して下方にドラッグコピーします。

=IF(B2="","",IF(COUNTIF(B$2:B2,B2)=1,INT(MAX(G$1:G1))+1,INDEX(G$1:G1,MATCH(B2,B:B,0))+COUNTIF(B$1:B1,B2)*0.0001))

そこで会社名ごとのシートですが例えばシート2のA1セルには会社名の文字が有りB1セルには具体的な会社名を入力します。
A2セルからF2セルまでにはシート1と同じ項目名を並べます。
A3セルには次の式を入力してF3セルまで横にドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(A1)>COUNTIF(Sheet1!$B:$B,$B$1),"",IF(INDEX(Sheet1!$A:$F,MATCH(INDEX(Sheet1!$G:$G,MATCH($B$1,Sheet1!$B:$B,0))+(ROW(A1)-1)*0.0001,Sheet1!$G:$G,0),COLUMN(A1))="","",INDEX(Sheet1!$A:$F,MATCH(INDEX(Sheet1!$G:$G,MATCH($B$1,Sheet1!$B:$B,0))+(ROW(A1)-1)*0.0001,Sheet1!$G:$G,0),COLUMN(A1))))

B1セルの会社名を変えることで表ができるわけですから他のシートについても同じ表を作成すればよいことになりますね。

アバター

質問した人からのコメント

2014/5/28 09:01:37

降参 どういう理屈で動いてるのか理解できてはいませんがやりたかったことが見事に出来て感動しました。

他の方のやり方も試したのですがマクロは基本的にサンプルをコピペして使うことしか出来ず、自分の環境に合った形にカスタマイズさせることが難しかったです。まことに申し訳ありません。

ベストアンサー以外の回答

1〜2件/2件中

並び替え:回答日時の
新しい順
|古い順

mie********さん

編集あり2014/5/2804:32:16

仮に、
元シ-ト(名)を、
Sheet1
として、

一行目は見出し項目行

二行目以降に、
A列には商品名、B列には会社名
というデ-タが入力されている、
という前提で、

B列の会社名デ-タから、
重複のない、
会社名ごとのシートを作成し、

その後、
元シ-トから、
空白行を除いて、
(B列の会社名を基準に)各行を、
会社名ごとのシートに、
振り分ける、
マクロコ-ドの一例をご紹介します。
..... 本来は、フィルタ-オプションによるマクロもあるのですが、
..... 会社名ごとのシートに、条件エリアを追加するので、
..... 若干見栄えが悪いかもしれないので、
..... 単純な、コピ-による方法にしました。


※ ' Sh.Cells.Clear はコメント行にしてあります。

マクロ実行のたびに、
新しい、
転記内容にしたいのですが、
既に、会社名シ-トがあり、
そのA列B列以外の、
シ-ト内に何らかの、
必要なデ-タがある場合でも、
削除(クリア)してしまう為、
コメント行化してあります。

会社名シ-トが未作成であったり、
新規の試行用のダミ-Bookで、
試される場合は、
先頭のアポストロフィを外して、
重複のない転記をご確認ください。





Option Explicit

Sub Test()
Dim Wh As Worksheet
Dim Dic As Variant, Keys As Variant
Dim Buf As String, Swap As String
Dim R As Long, Rw As Long
Dim i As Long, j As Long, Rww As Long
Dim Flag As Boolean, Sh As Worksheet

Set Wh = Worksheets("Sheet1") ' ← 実際の元シ-ト名を記述
Set Dic = CreateObject("Scripting.Dictionary")
Flag = False

On Error Resume Next

Rw = Wh.Range("B" & Rows.Count).End(xlUp).Row

For R = 2 To Rw
If Cells(R, 2) <> "" Then
Buf = Cells(R, 2)

If Not Dic.Exists(Buf) Then
Dic.Add Buf, Buf
End If
End If
Next

Keys = Dic.Keys

For i = 0 To Dic.Count - 1
For j = Dic.Count - 1 To i Step -1
If Keys(i) > Keys(j) Then
Swap = Keys(i)
Keys(i) = Keys(j)
Keys(j) = Swap
End If
Next j
Next i

Application.ScreenUpdating = False

For i = LBound(Keys) To UBound(Keys)

For Each Sh In Worksheets
If Sh.Name = Keys(i) Then
Flag = True
End If
Next

If Flag = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Keys(i)
End If

Flag = False
Next

For i = LBound(Keys) To UBound(Keys)
For Each Sh In Worksheets
If Sh.Name = Keys(i) Then
' Sh.Cells.Clear
Wh.Range("A1:B1").Copy Destination:=Sh.Range("A1")

For j = 2 To Rw
Rww = Sh.Range("B" & Rows.Count).End(xlUp).Row + 1
If Wh.Range("B" & j) = Keys(i) Then
Wh.Range("A" & j & ":B" & j).Copy _
Destination:=Sh.Range("A" & Rww)
End If
Next

Sh.Columns.AutoFit

End If
Next
Next

Dic.RemoveAll
Set Dic = Nothing: Set Wh = Nothing

Application.ScreenUpdating = True

End Sub

gar********さん

2014/5/2715:32:18

それこそマクロでポンで行えばいい作業だと思います。
B列を1行目から最終行まで
空白でなければ、
B列と同じシート名の最終行の一つ下にA列の値を追加するマクロです。
細かくはそちらの状況に合わせて編集してもらえればいいかと思います。
実行前に会社シートの値をクリアしたり、新しいシートを作ったりするといいかと思います。

Sub macro1()
Dim rng As Range
For Each rng In Range(Cells(1, 2), Cells(Rows.Count, 2).End(xlUp))
If rng <> "" Then
Worksheets(rng).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = rng.Offset(0, -1)
End If
Next
End Sub

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる