- ベストアンサー
VBA ソートに関する初心者の質問
_Kyleの回答
#1-2です。 こちらこそ何度もスミマセン。 ん～、「何事もなく終了」しちゃいましたか。 Checkが全部OKだったということは 範囲と値は取れてるんですね。 であれば、 ●「ヒットしてない」（検索がうまくいってない） ●「コピペできてない」（貼り付けがうまくいってない） のどちらかということになりますが…… -------------------------- ◆確認 bシートの検索ID列にあるIDは 例： 12345_DEF-TOUKYOUTOTOSHIMAKU のように [aシートの検索ID]＋[半角のアンダースコア(_)]＋[文字列] のカタチになってるんですよね？ 提示したコードは、 【[bシートの検索ID](アタマに[B]がついていれば取ったもの)】 のうちから 【[aシートの入力ID]の後ろに[半角のアンダースコア]と[任意の文字列]をつけたもの】 を探します。 -------------------------- ◆テストコードの[■検索・コピペ]部分を 次のように差し替えて、 【aシート２～３行,bシート10行程度のダミーデータで】 テストしみてください。 （実データでやると終わらないので） うまくいくようでしたら Application.ScreenUpdating = True と MsgBox を外してそのままお使いください。 ※中断する場合は ESCキーではなくCtrl＋Breakを使ってください。 '-----↓サシカエ↓------------------------------- '■検索・コピペ 'うまくいったら削除 Application.ScreenUpdating = True 'aシートの入力IDを1番目から最後まで調べる For i = 1 To ipCnt '結果列にとりあえず「該当なし」と入れておく rtRng.Cells(i, 1).Value = "該当なし" 'aシートのi番目の入力IDの後ろに"_*"を付ける ' "99999_*"のカタチにする ' "*"は[任意の文字列]を意味する[ワイルドカード]です。 tpStr = ipAry(i) & "_*" 'bシートの検索IDを最後から1番目までチェック For j = idCnt To 1 Step -1 MsgBox _ "較べてみるよ" & vbCrLf & vbCrLf & _ "aシート入力ID： " & tpStr & vbCrLf & _ "bシート検索ID： " & idAry(j) 'もし、bシートのj番目の検索IDが '[i番目の入力ID]_[ABCDEFG…]というカタチなら If idAry(j) Like tpStr Then MsgBox "ヒットしたよ！ ＼(^o^)／" 'bシートリンク列の、 '検索IDと同じ行のセル(i番目のセル)をコピーして 'aシート結果列の、 '入力IDと同じ行のセル(j番目のセル)に貼り付ける lkRng.Cells(j, 1).Copy _ Destination:=rtRng.Cells(i, 1) MsgBox "コピーしたよ！" 'ヒットしたので残りの検索IDは飛ばして次の入力IDへ Exit For End If '次の検索IDを調べる Next j '次の入力IDを調べる Next i '-----↑サシカエ↑------------------------------- 動画付けてみました。 音は出ませんからどうぞご安心を。
関連する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 シート１の A列に数値で得点が入っています。
- ベストアンサー
- その他（プログラミング・開発）
- VBAで教えて下さい。続き
昨日ＶＢＡの事で質問し回答を頂いたのですが追加で質問があります。ベストアンサーを選ぶと質問は締め切られる事を知らずにお礼をしたら終わってしまっていました。どなたか宜しくお願い致します。 最初の質問は 表を作りたいのですが、 顧客名のシートを１００枚ほど作り、シート１（シート１は検索シートにしたいので顧客名は無）のA1にクライアント名を入力したら入力した顧客名シートが出てくる様にしたいです。 以上が最初の質問です。 以下の書式がベストアンサーに選らばせて頂いた方の回答です。 これで動くようになったのですが、 追加で シートのC1に顧客のＩＤ数字が7ケタあるのですが、顧客名シート検索かＩＤ検索どちらかで一方入力した場合のコードとかは教えて頂いたコードに足せば可能ですか？ というのが質問です。 宜しくお願い致します。 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を色々な資料を基に、「テスト２」のシートに条件検索されたデータ、マクロ起動（？）で「入力履歴」に追記されるものを作成しました。 Sub prog() Dim myFld As String, myCri As String Dim myRow As Long Dim Sh2 As Worksheet, Sh3 As Worksheet Set Sh2 = Worksheets("テスト２") 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初心者です。始めてから２，３週間です。 表を作りたいのですが、 顧客名のシートを１００枚ほど作り、シート１（シート１は検索シートにしたいので顧客名は無）の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ステートメントで実行時エラー１３になります。 ご教示いただけませんでしょうか？ 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
- ベストアンサー
- オフィス系ソフト
お礼
できました！ありがとうございます！！ この先もまだ続きますが、大きな一歩が踏み出せました 無い様に心がけますが、次がありましたらよろしくお願いします。 本当にありがとうございました^^