[[20050314095500]] 『データの抽出について』(エクセル初級者 わたりん) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『データの抽出について』(エクセル初級者 わたりん)

  初級者です。処理方法を教えてください。シート1に図書原簿として約7000冊のデータがあります。
この原簿の中から紛失している本を抽出する作業を行いたいのですが、…
 シート1の原簿には、A列に書籍番号、B列に書名、C列に分類番号…とI列まで項目があります。
実在する書籍番号をシート2に入力しました。(書籍番号のみ入力)
 まず、シート2に入力した実在する書籍について、シート1にあるB列の書名以降のデータを貼り付け、
  次に、シート1の中からシート2にないデータをシート3に抽出(紛失している書籍)したいので
すが、マクロでも結構ですのでご教授ください。よろしくお願いいたします。
 なお、OSは、Windows98エクセルバージョンは、Excel2000です。


 こちらが参考になりませんか?
[[20050307223442]]『大量のデータの照合』(shouta) 
(SoulMan)


7000冊はものすごい料ですね、理論的には、シート2に抽出欄(任意の列、仮にj列としましょう)を作り、if(or(exact(sheet2!B2,sheet1!$b$2:$b$7000)),"","紛失")で
sheet3に、A列に書籍番号(ただし、sheet2のA列は番号順が条件です)index(sheet2!$a$2:$a$7000,
match(small(if(sheet2!$j2:$j$7000=”紛失",sheet2!$a$2:$a$7000),row()-1),sheet2!$a$2:$a$7000,0))
で任意のところまでコピーします。エラー(#num)が気になれば、indexの前にif(iserror(match(small(if(sheet2!$j2:$j$7000=”紛失",sheet2!$a$2:$a$7000),row()-1),sheet2!$a$2:$a$7000,0)),""を付け足します、式の終わりのほうに付け足した、if分の左かっこを忘れずに、b列、以左はiserror(),の代わりにif($a2="",となります。
これで、抽出は出来ると思いますが、ものすごい、時間がかかると思います。
(kita)


SoulManさん、kitaさん早速のアドバイスありがとうございます。

ところで、『大量データの照合』では、BOOK1とBOOK2の中のシート作業ですが、
同一ブック内のシート1とシート2について処理をさせるには、どこを修正したらいいのか教えてください。
初級者でコード書き換えに不安があります。
(重複があったらエラーとなるのでしょうか。)
よろしくお願いいたします。
(わたりん)


 Sheet2のA列にないSheet1のA列のデータをSheet3のA列に書き出します。
どうでしょうか?
Option Explicit
Sub てすと()
Dim MyDic As Object
Dim MyA As Variant, MyB As Variant, MyAry() As Variant
Dim i As Long, n As Long, k As Long, MyTimer As Single
Set MyDic = CreateObject("Scripting.Dictionary")
MyTimer = Timer
With Sheets("Sheet2")
    MyB = .Range("A1", .Range("A65536").End(xlUp)).Value
End With
For i = 1 To UBound(MyB, 1)
    If Not MyDic.Exists(MyB(i, 1)) Then MyDic.Add MyB(i, 1), Empty
Next
With Sheets("Sheet1")
    MyA = .Range("A1", .Range("A65536").End(xlUp)).Resize(, 9).Value
    ReDim MyAry(1 To UBound(MyA, 1), 1 To UBound(MyA, 2))
    For i = 1 To UBound(MyA, 1)
        If Not MyDic.Exists(MyA(i, 1)) Then
        k = k + 1
        For n = 1 To UBound(MyA, 2)
            MyAry(k, n) = MyA(i, n)
        Next
        End If
    Next
End With
With Sheets("Sheet3")
    .Range("A:I").Clear
    .Range("A1").Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
End With
MyTimer = Timer - MyTimer
MsgBox Format(MyTimer, "#,##0.00") & "処理完了!!"
Erase MyA, MyB, MyAry
Set MyDic = Nothing
End Sub
(SoulMan)


 お手数かけます。
 できたらSheet1のB列以降(列はIまで)もSheet3に書き出したいのですが、…
(Sheet2は、A列に書籍番号のみ入力されています。)
よろしくお願いします。
(わたりん)


 上のコードを直しておきました。お試しください。
(SoulMan)


 ありがとうございました。
短時間で抽出できました。
(わたりん)

 昨日、アドバイスを頂き抽出作業ができたのですが、一カ所不具合が生じています。
またまた、教えてください。
 シート1のB列にある4−1、8-1などのデータがシート3のB列にに抽出されたとき
 月日に、また、38−1がjan−38に、51−2などがFed-51に変わっています。
 該当するB列をセルの書式設定で表示形式ー文字列に変えたのですがうまくいきません。
 シート1のB列の状態(形式)でシート3に抽出するにはどうすればよいのでしょうか。
 よろしくお願いいたします。
 (わたりん)

 最後の方の↓を
With Sheets("Sheet3")
    .Range("A:I").Clear
    .Range("A1").Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
End With
これに↓変更してみてください。。
With Sheets("Sheet3")
    .Range("A:I").ClearContents
    .Columns("B:B").NumberFormatLocal = "@"
    .Range("A1").Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
End With
(SoulMan)

 ありがとうございました。
 シート1のB列の状態で抽出できました。
 素早いアドバイスに感謝しています。これからマクロを頑張ってみたいと思いますが、
 難しくて…
 「学はまねよ!」の精神でまいりますので、これからもよろしくお願いいたします。
 本当にありがとうございました。
 (わたりん)

 お世話になります。
 過去ログであった質問と思い単語検索で探しましたが…。見つかりません。
 また教えてください。
 A列B列両方にあるものをCに抽出したいのですが…
 たとえば、次のようなA列B列データからC列を抽出するようなマクロを
 教えてください。(A列に3000件、B列には1500件程度入力)
 A	B	C
 1	1	1
 2	2	2
 4	3	9
 6	5	10
 8	7	 
 9	9	 
 10	10	 
 12	15	 
 14	 	 
 16	 	 
 よろしくお願いいたします。
 (わたりん)

 なんかあったなぁ・・っと思ったら、、、ずばりでしょう??(;^_^A アセアセ・・・
[[20050305200025]]『A列とB列で一致するものだけをC列へ』(ラーメン君) 
(SoulMan)

 ほんと!そのものズバリでした。ありがとうございます。
 (わたりん)

 おはようございます。
 またまた、アドバイスください。
 シート1に列Aから列1までデータが入力されています。
 F列には分類という項目があり、000〜999までと「絵本」を意味する
 「え」が入力されています。
 (例えば、F列に下記のように)
    F 
    分 類
      908
      120
      012
       え
      384
      916
 このようなデータから0類〜9類及び「え」の分類毎に別シートに抽出する方法を
 教えてください。(分類番号の左端文字による分類方法です。)
 よろしくお願いいたします(わたりん)

 おまたせ(;^_^A あせあせ・・・
今日は、忙しくて今になってしまった。。といことで、二種類作ってみました。
一つは、シートを作ってそこに抽出するタイプ
もう一つはSheet2に分類別に並び替えて出力するタイプ
並び替える方はTransposeを使っているので数に限りがあるかもしれません。。
Option Explicit
Sub てすといち()
Dim MyA As Variant, MyAry() As Variant
Dim MySheet As Variant, MyItem As Variant
Dim Wh As Worksheet, MyTitle As Variant
Dim i As Long, j As Long, n As Long, k As Long
Dim MyTimer As Single
Dim MyFlag As Boolean
MyTimer = Timer
MySheet = Array("0類", "1類", "2類", "3類", "4類", "5類", "6類", "7類", "8類", "9類", "絵本")
MyItem = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "え")
For i = LBound(MySheet) To UBound(MySheet)
    For Each Wh In Worksheets
        If Wh.Name = MySheet(i) Then MyFlag = True: Exit For
    Next
    If MyFlag = False Then
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = MySheet(i)
    End If
Next i
With Sheets("Sheet1")
    MyTitle = .Range("A1:I1").Value
    MyA = .Range("A2", .Range("A65536").End(xlUp)).Resize(, 9).Value
End With
For j = LBound(MyItem) To UBound(MyItem)
    k = 0
    ReDim MyAry(1 To UBound(MyA, 1), 1 To UBound(MyA, 2))
    For i = 1 To UBound(MyA, 1)
        If Left(Trim(MyA(i, 6)), 1) = MyItem(j) Then
            k = k + 1
            For n = 1 To UBound(MyA, 2)
                MyAry(k, n) = MyA(i, n)
            Next
        End If
    Next
    With Sheets(MySheet(j))
        .Range("A:I").ClearContents
        .Range("B:B,F:F").NumberFormatLocal = "@"
        .Range("A1:I1").Value = MyTitle
        .Range("A2").Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
    End With
Next
MyTimer = Timer - MyTimer
MsgBox Format(MyTimer, "#,##0.00") & "処理完了!!"
Erase MyA, MyAry, MySheet, MyItem, MyTitle
End Sub
Option Explicit
Sub てすとに()
Dim MyA As Variant, MyAry() As Variant
Dim MyTitle As Variant
Dim i As Long, n As Long, k As Long
Dim MyKey As String
Dim MyTimer As Single
MyTimer = Timer
With Sheets("Sheet1")
    MyTitle = .Range("A1:I1").Value
    MyA = .Range("A2", .Range("A65536").End(xlUp)).Resize(, 10).Value
End With
For i = 1 To UBound(MyA, 1)
    MyKey = Left(Trim(MyA(i, 6)), 1)
    If Not IsEmpty(MyKey) Then
        If IsNumeric(MyKey) Then
            k = k + 1
            ReDim Preserve MyAry(1 To UBound(MyA, 2), 1 To k)
            For n = 1 To UBound(MyA, 2) - 1
                MyAry(n, k) = MyA(i, n)
            Next
            MyAry(UBound(MyA, 2), k) = (MyKey + 1) * 100000000 + i
        ElseIf MyKey = "え" Then
            k = k + 1
            ReDim Preserve MyAry(1 To UBound(MyA, 2), 1 To k)
            For n = 1 To UBound(MyA, 2) - 1
                MyAry(n, k) = MyA(i, n)
            Next
            MyAry(UBound(MyA, 2), k) = 11 * 100000000 + i
        End If
    End If
Next
MyAry = Application.Transpose(MyAry)
QuickSort MyAry, UBound(MyAry, 2), LBound(MyAry, 1), UBound(MyAry, 1)
With Sheets("Sheet2")
    .Range("A:I").ClearContents
    .Range("B:B,F:F").NumberFormatLocal = "@"
    .Range("A1:I1").Value = MyTitle
    .Range("A2").Resize(UBound(MyAry, 1), UBound(MyAry, 2) - 1).Value = MyAry
End With
MyTimer = Timer - MyTimer
MsgBox Format(MyTimer, "#,##0.00") & "処理完了!!"
Erase MyA, MyAry, MyTitle
End Sub
Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight As Long)
Dim MySMid As Long
Dim i As Long, j As Long, n As Long
Dim MySLBound As Long, MySUBound As Long
Dim MyStmp As String
MySLBound = LBound(MySAry, 2)
MySUBound = UBound(MySAry, 2)
MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey)
i = MySLeft
j = MySRight
    Do
        Do While MySAry(i, MySKey) < MySMid
            i = i + 1
        Loop
        Do While MySAry(j, MySKey) > MySMid
            j = j - 1
        Loop
        If i >= j Then Exit Do
        For n = MySLBound To MySUBound
            MyStmp = MySAry(i, n)
            MySAry(i, n) = MySAry(j, n)
            MySAry(j, n) = MyStmp
        Next
        i = i + 1
        j = j - 1
    Loop
If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1
If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight
End Sub
(SoulMan)

 SoulMan様
 忙しい中、手間のかかるマクロを作成していただきありがとうございます。
 オートフィルのオプションで時間を掛けて手作業処理かなと思っていましたが、…
 てすといちで簡単に分類抽出ができました。
 本当にありがとうございます。
 これからもお手数かけますがよろしくお願いいたします。
 (わたりん)


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.