- ベストアンサー
VBA ソートに関する初心者の質問
_Kyleの回答
- _Kyle
- ベストアンサー率78% (109/139)
既に自己解決されたかもしれませんが…。 ※ワークシート機能の[検索]ではなく、 VBA上でデータを照合します。 ※aシート入力列・bシートID列とも、 途中に空白が無い前提です。 ※bシートは、開いて読んで閉じるだけで、 いじらないのでコピーしていません。 ※bシートのID列を読む際、アタマに"B"がついていれば、 削ってから配列に格納します。 ※bシートのID列を【下から】チェックして、 最初にヒットした行のリンクをコピーします。 ※コードでセル範囲を指定している部分は 【見出し行を含めずに】指定してください。 aシート:50件 bシート:3万件 について手元の環境でテストしたところ、 大量のリンクが貼られた[bシートのあるブック名.xls]を開く処理に10数秒を要するものの 検索・コピペ自体は0.5秒程度で終了します。 仕様が動くかもと思って丁寧に書きましたが前処理が大げさですね。 素人の手すさびなので 「お手本」にはしない方がよいかもしれません。(^^;;;;;;;; Excel2003で動作確認。 もしうまくいかないようでしたら ・エラーの内容とエラーになる場所 ・Excelのバージョン を補足していただければ戻ってきます。 '-----↓ココカラ↓------------------------------- Sub DATA_IMPORT_macro() '■宣言 Dim myBok As Workbook 'aシートのあるブック Dim dtBok As Workbook 'bシートのあるブック Dim mySht As Worksheet 'aシート Dim dtSht As Worksheet 'bシート Dim ipRng As Range 'aシートの入力列 Dim rtRng As Range 'aシートの結果列 Dim idRng As Range 'bシートのID列 Dim lkRng As Range 'bシートのリンク列 Dim ipAry() As String 'aシートの入力ID Dim idAry() As String 'bシートのIDデータ Dim ipCnt As Long 'aシートの入力ID数 Dim idCnt As Long 'bシートのID数 Dim tpAry As Variant Dim tpItm As Variant Dim tpStr As String Dim i As Long Dim j As Long '■お約束 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '■オブジェクト格納 Set myBok = Workbooks("aシートのあるブック名.xls") Set mySht = myBok.Worksheets("aシート名") Set ipRng = mySht.Range("B3:B999") Set rtRng = mySht.Range("I3:I999") Set dtBok = Workbooks.Open( _ Filename:="bシートのあるブック名.xls", _ ReadOnly:=True) Set dtSht = dtBok.Worksheets("bシート名") Set idRng = dtSht.Range("C4:C39999") Set lkRng = dtSht.Range("F4:F39999") '■データ格納(aシート) ReDim ipAry(1 To ipRng.Rows.Count) ipCnt = 0 tpAry = ipRng.Value For Each tpItm In tpAry If tpItm = "" Then Exit For ipCnt = ipCnt + 1 ipAry(ipCnt) = tpItm Next tpItm ReDim Preserve ipAry(1 To ipCnt) '■データ格納(bシート) ReDim idAry(1 To idRng.Rows.Count) idCnt = 0 tpAry = idRng.Value For Each tpItm In tpAry If tpItm = "" Then Exit For idCnt = idCnt + 1 If Left(tpItm, 1) = "B" Then tpItm = Mid(tpItm, 2) End If idAry(idCnt) = tpItm Next tpItm ReDim Preserve idAry(1 To idCnt) '■検索・コピペ For i = 1 To ipCnt tpStr = ipAry(i) & "_*" For j = idCnt To 1 Step -1 '下から見る If idAry(j) Like tpStr Then lkRng.Cells(j, 1).Copy _ Destination:=rtRng.Cells(i, 1) Exit For End If Next j Next i '■終了 dtBok.Close Application.Calculation = xlCalculationAutomatic End Sub '-----↑ココマデ↑------------------------------- 以上ご参考まで。長乱コード陳謝。
関連するQ&A
- 印刷後のVBAの実行 (3)
Private Sub Workbook_BeforePrint(Cancel As Boolean) If ActiveSheet.Name = "Sheet1" Then If Range("D6").Value = "" Then Cancel = True MsgBox ("名前を入力してください") Range("D6").Select Exit Sub End If Else If ActiveSheet.Name = "Sheet2" Then If Range("C11").Value = "" Then Cancel = True MsgBox ("受付時間を入力してください") Range("C11").Select Exit Sub End If Else Exit Sub End If End If If Worksheets("Sheet1").Range("D5") = "不要" Then GoTo P1 ActiveSheet.Range("A70:Y70").Copy If Worksheets("Sheet3").Range("A1").Value = "" Then Worksheets("Sheet3").Range("A1").PasteSpecial Paste:=xlPasteValues Else Worksheets("Sheet3").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial _ Paste:=xlPasteValues End If Application.CutCopyMode = False P1: ActiveSheet.Range("A1").Select End Sub sheet1のD5に「不要」と入っていたら 24~33行目の作業がキャンセルになりますが sheet2のD5にも「不要」と入っていたら、同じ様にキャンセルできる様に出来ますでしょうか? ご回答お願いします
- 締切済み
- オフィス系ソフト
- 印刷後のVBAの実行 (2)
Private Sub Workbook_BeforePrint(Cancel As Boolean) If ActiveSheet.Name = "Sheet1" Then If Range("D6").Value = "" Then Cancel = True MsgBox ("名前を入力してください") Range("D6").Select Exit Sub End If Else If ActiveSheet.Name = "Sheet2" Then If Range("C11").Value = "" Then Cancel = True MsgBox ("受付時間を入力してください") Range("C11").Select Exit Sub End If Else Exit Sub End If End If ActiveSheet.Range("A70:Y70").Copy If Worksheets("Sheet3").Range("A1").Value = "" Then Worksheets("Sheet3").Range("A1").PasteSpecial Paste:=xlPasteValues Else Worksheets("Sheet3").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial _ Paste:=xlPasteValues End If Application.CutCopyMode = False ActiveSheet.Range("A1").Select End Sub 先日、上記のコードを回答者の方から教えてもらい、とても助かっていますが sheet1のD5に「不要」という文字が入っていた場合、 sheet3への貼り付け(23~30行目の作業)をキャンセルして、最後にsheet1のA1を選択するようにはどの様にしたらいいでしょうか?
- 締切済み
- オフィス系ソフト
- 全くの初心者ですVBA
どこが悪いかわかりません。 教えてください。 Sub テスト() Dim kekka As String Dim i As Integer tokuten = Worksheets("Sheet1").Cells(i, 1).Value For i = 1 To Worksheets("Sheet1").Range("A1").End(xlDown).Row.Count If tokuten >= 80 Then kekka = "合格" Else kekka = "不合格" kekka = Cells(i, 2) End If Next i End Sub シート1の A列に数値で得点が入っています。
- ベストアンサー
- その他(プログラミング・開発)
- VBAで教えて下さい。続き
昨日VBAの事で質問し回答を頂いたのですが追加で質問があります。ベストアンサーを選ぶと質問は締め切られる事を知らずにお礼をしたら終わってしまっていました。どなたか宜しくお願い致します。 最初の質問は 表を作りたいのですが、 顧客名のシートを100枚ほど作り、シート1(シート1は検索シートにしたいので顧客名は無)のA1にクライアント名を入力したら入力した顧客名シートが出てくる様にしたいです。 以上が最初の質問です。 以下の書式がベストアンサーに選らばせて頂いた方の回答です。 これで動くようになったのですが、 追加で シートのC1に顧客のID数字が7ケタあるのですが、顧客名シート検索かID検索どちらかで一方入力した場合のコードとかは教えて頂いたコードに足せば可能ですか? というのが質問です。 宜しくお願い致します。 Private Sub Worksheet_Change(ByVal Target As Range) Dim k As Long, str As String, myFlg As Boolean str = Range("A1") For k = 1 To Worksheets.Count If Worksheets(k).Name = str Then myFlg = True Exit For End If Next k If myFlg = True Then Worksheets(str).Activate Else MsgBox "該当シートなし" End If End Sub
- ベストアンサー
- Visual Basic
- ロートルの初心者です、VBAについての質問です。
エクセル2003で以下のVBAを色々な資料を基に、「テスト2」のシートに条件検索されたデータ、マクロ起動(?)で「入力履歴」に追記されるものを作成しました。 Sub prog() Dim myFld As String, myCri As String Dim myRow As Long Dim Sh2 As Worksheet, Sh3 As Worksheet Set Sh2 = Worksheets("テスト2") Set Sh3 = Worksheets("入力履歴") With Sh2 myRow = .Range("D" & Rows.Count).End(xlUp).Row Range("A1:H" & myRow).Copy Destination:=Sh3.Range("A" & Rows.Count).End(xlUp).Offset(1) End With Sh3.Activate Range("A1").Select End Sub ここで問題となるのが抽出データには関数が含まれているため「入力履歴」シートに書き込まれたデータにもそのまま貼り付けられるので「#A/N」となってしまいます。 Range("A1:H" & myRow).Copy Destination:=Sh3.Range("A" & Rows.Count).End(xlUp).Offset(1)の 「Destination」を変えれば良いかと思ったのですが・・・、うまくいきません。 エクセルでいう、「形式を選択して貼り付け→値」をやりたいのですが書き方がわかりません。 ロートルの初心者によろしく愛の手をお願い申します。 PS:説明文があると助かります。
- ベストアンサー
- オフィス系ソフト
- VBAで教えて下さい。
VBA初心者です。始めてから2,3週間です。 表を作りたいのですが、 顧客名のシートを100枚ほど作り、シート1(シート1は検索シートにしたいので顧客名は無)のA1にクライアント名を入力したら入力した顧客名シートが出てくる様にしたいです。 参考書、ネット等をみて作成しましたがエラーが出ます。作動するにはどの様にしたら宜しいでしょうか?どうかお助け下さい。宜しくお願い致します。コードは下記です。 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Integer Dim myWSname As String, myworksheet As Worksheet myWSname = "i" myWSname = Worksheets("sheet2").Range("A1").Value For Each myworksheet In Worksheets If myworksheet.Name = mayWSname Then Worksheets("myWSname").Activate Exit Sub End If Next myworksheet End Sub
- ベストアンサー
- Visual Basic
- VBA beforeprintについて
Private Sub Workbook_BeforePrint(Cancel As Boolean) If ActiveSheet.Name = "sheet1" Then If Range("M1").Value = "" Then Cancel = True MsgBox ("名前を入力してください") Range("M1").Select Exit Sub End If ElseIf ActiveSheet.Name = "sheet2" Then If Range("A47").Value = 文字 Then Cancel = True MsgBox ("日付を入力してください") Range("A47").Select Exit Sub End If Exit Sub End If End Sub 上記は印刷をする前に実行されるコードですが、上記を実行して印刷をした後に自動で下記のVBAを実行したいのですが Sub データー取り込み() ActiveSheet.Range("B2000:Z2000").Copy ChDir "\\データーA\データーB\データーC\データーD" Workbooks.Open Filename:="\\データーA\データーB\データーC\データーD\データーシート1.xls" Sheets("顧客データー").Select If Worksheets("顧客データー").Range("B18").Value = "" Then Worksheets("顧客データー").Range("B18").PasteSpecial Paste:=xlPasteValues Else Worksheets("顧客データー").Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial _ Paste:=xlPasteValues End If ActiveWorkbook.Save ActiveWindow.Close End Sub 上記のコードと下記のコードをどのように絡めたらいいのかわかりません。アドバイスお願いします。
- ベストアンサー
- オフィス系ソフト
- エクセルVBA の変数を使うべきでしょうか?
はじめまして。エクセル初心者です。 書籍やサイトで勉強させてもらっていますが、VBAがなかなか難しくてすぐに壁にぶつかってしまいます。少々困ってしまい、詳しい方のアドバイスを頂ければと質問を投稿させていただきました。 どうか宜しくお願い致します。質問ですが、 以下のようなコードで、sheet5のB列の任意のセルをダブルクリックした場合、sheet5のBCD列の同じ行のセル値がsheet1の指定した列に入力されるという処理を作りました。 これで一応目的の動作はするのですが、数が増えると「コンパイルエラー・プロシージャが大きすぎます」というメッセージがでてしまいます。列や行には規則性があるので、もしかしたら変数というものを使ってコードを書き直せばいいのかなと思いネットで調べてみたのですが、今のところさっぱり理解できません。 申し訳ありませんが、分かりやすくご教授いただけないでしょうか。バージョンは2003を使っています。 また、下のコードですと、sheet5のBCDいずれかのセルに空白があった場合、sheet1の列に入力されるときに入力される行がずれてしまいます。今は空白を何かで埋めて対処しているのですが、この問題の解決策も教えて頂けると助かります。どうか宜しくお願い致します。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, cancel As Boolean) If Target.Address = "$B$2" Then Worksheets("sheet1").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Target.Value Worksheets("sheet1").Range("H" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("B2") Worksheets("sheet1").Range("K" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("C2") Worksheets("sheet1").Range("M" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("D2") Worksheets("sheet1").Activate cancel = True End If If Target.Address = "$B$3" Then Worksheets("sheet1").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Target.Value Worksheets("sheet1").Range("H" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("B3") Worksheets("sheet1").Range("K" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("C3") Worksheets("sheet1").Range("M" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("D3") Worksheets("sheet1").Activate cancel = True End If If Target.Address = "$B$4" Then Worksheets("sheet1").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Target.Value Worksheets("sheet1").Range("H" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("B4") Worksheets("sheet1").Range("K" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("C4") Worksheets("sheet1").Range("M" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("D4") Worksheets("sheet1").Activate cancel = True End If ・ ・ ・ ・ ・ ・ End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBAについて質問です。(超初心者です。)
この度初めて投稿させて頂きます。 当方、VBAを始めてまだ1ヶ月も経たない初心者ですが、何卒宜しくお願い致します。 まずやろうとしていることですが、 表(5列)の1行から言葉を検索し、その言葉がある1列のみにロック(入力等の操作不可)をかけ、その後複数カラムのロックを解除、入力を可能なものにするというものです。(説明が下手で申し訳ないです。) 恥ずかしながらコードの方を記載します。 Sub test() Dim KEKKA As Range Dim I As Long Dim J As Long With Worksheets("シート名") For I = 2 To 6 Set KEKKA = .Range("B1" & I).Find(what:="ABC") If KEKKA Is Nothing Then ElseIf Not KEKKA Is Nothing Then ' シート保護を解除 ActiveSheet.Unprotect For J = 1 To 27 '該当するセルの一列をロック .Range("B1" & I).Offset(0, J).MergeArea.Locked = True【ここでエラーになります。「RangeクラスのLockedプロパティを設定できません。」】 'ロックを有効にする。 ActiveSheet.Protect Next J .Range("X1" & I).Locked = False .Range("Z1" & I).Locked = False .Range("AB1" & I).Locked = False End If Next I End With End Sub デバックしてみたのですが、I・Jには値が代入されていました。 また、offset部分を外したりすると(求める動作ではなくなりますが、原因を突き止めるために試したりしています。)「型が一致しません。」というエラーになります。 おそらく相当初歩的なことだとは思われますが、何卒ご助力願えますよう、お願いいたします。 OS:XP エクセルバージョン:2000
- ベストアンサー
- Visual Basic
- VBA Setステートメント
エクセル2002使用です。 B列に本日の日付が入るようにワークシートに関数(DAY関数)が入っています。 そのB列を検索して、同じ日付け(数字)がなければ、今日の日付を入力するVBAを組もうと思っているのですが、 Setステートメントで実行時エラー13になります。 ご教示いただけませんでしょうか? Private Sub CommandButton1_Click() ' 出勤ボタン B列に同日日付があればキャンセル Dim tuki, Hiduke1 As String Dim Hiduke1kekka As Variant tuki = Range("B3").Value Hiduke1 = Range("D3").Value Worksheets(tuki & "月").Activate Set Hiduke1kekka = ActiveSheet.Columns("B:B") _ .Find(What:=Hiduke1, After:=ActiveCell, LookIn:=xl, LookAt _ :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ False, MatchByte:=False, SearchFormat:=False) If Hiduke1kekka Is Nothing Then ActiveSheet.Range("D1000").End(xlUp).Select Selection.Value = "出" Worksheets("sheet1").Activate Else Worksheets("sheet1").Activate Exit Sub End If End Sub
- ベストアンサー
- オフィス系ソフト
お礼
どうもありがとうございます、あれから遅々として進まず 悩み続けていましたので大変助かります。 記載して頂いたプログラムを転記してファイル名等を変更し マクロを走らせて見ているのですが、走らせるたびにエラーの内容が変わっているみたいでした ファイル名相違等のケアレスな部分等も意識して修正しているのですが なかなか原因の特定ができていません また、書いて頂いている内容もきちんと理解できないものが多い為 ネットで調べながらやってますが会社でしかできない為 亀の歩みではありますがまた質問できる状態になりましたらさせて頂きたいと思います ちなみにExcelは2003です。