[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『データの抽出について』（エクセル初級者 わたりん）
初級者です。処理方法を教えてください。シート１に図書原簿として約7000冊のデータがあります。 この原簿の中から紛失している本を抽出する作業を行いたいのですが、… シート１の原簿には、Ａ列に書籍番号、Ｂ列に書名、Ｃ列に分類番号…とI列まで項目があります。 実在する書籍番号をシート2に入力しました。（書籍番号のみ入力） まず、シート２に入力した実在する書籍について、シート1にあるB列の書名以降のデータを貼り付け、 次に、シート１の中からシート２にないデータをシート３に抽出（紛失している書籍）したいので すが、マクロでも結構ですのでご教授ください。よろしくお願いいたします。 なお、OSは、Windows98エクセルバージョンは、Excel2000です。
こちらが参考になりませんか？ [[20050307223442]]『大量のデータの照合』（shouta） （SoulMan）
ところで、『大量データの照合』では、BOOK1とBOOK2の中のシート作業ですが、
同一ブック内のシート１とシート２について処理をさせるには、どこを修正したらいいのか教えてください。
初級者でコード書き換えに不安があります。
（重複があったらエラーとなるのでしょうか。）
よろしくお願いいたします。
（わたりん）
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のＢ列以降（列はＩまで）もSheet3に書き出したいのですが、… （Sheet2は、Ａ列に書籍番号のみ入力されています。） よろしくお願いします。 （わたりん）
上のコードを直しておきました。お試しください。 （SoulMan）
昨日、アドバイスを頂き抽出作業ができたのですが、一カ所不具合が生じています。 またまた、教えてください。 シート１のＢ列にある4－1、8-1などのデータがシート３のB列にに抽出されたとき 月日に、また、38－1がｊａｎ－38に、51－2などがFed-51に変わっています。 該当するB列をセルの書式設定で表示形式ー文字列に変えたのですがうまくいきません。 シート１のＢ列の状態（形式）でシート３に抽出するにはどうすればよいのでしょうか。 よろしくお願いいたします。 (わたりん）
最後の方の↓を
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）
ありがとうございました。 シート１のＢ列の状態で抽出できました。 素早いアドバイスに感謝しています。これからマクロを頑張ってみたいと思いますが、 難しくて… 「学はまねよ！」の精神でまいりますので、これからもよろしくお願いいたします。 本当にありがとうございました。 （わたりん）
お世話になります。 過去ログであった質問と思い単語検索で探しましたが…。見つかりません。 また教えてください。 Ａ列Ｂ列両方にあるものをＣに抽出したいのですが… たとえば、次のようなＡ列B列データからＣ列を抽出するようなマクロを 教えてください。(Ａ列に3000件、Ｂ列には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までデータが入力されています。
Ｆ列には分類という項目があり、000～999までと「絵本」を意味する
「え」が入力されています。
（例えば、Ｆ列に下記のように）
Ｆ
分 類
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.