• 締切済み
  • 困ってます

過去のリンクhttp://okwave.jp/qa

過去のリンクhttp://okwave.jp/qa9671557.html いつもありがとうございます。今回はシート1のA3セルに4901777という数字を入れた時にC4セルに改行された時にNAME1と表示されるコード、、なのですが、試作だけにコードの見映えがよくありません。何十何百となった時にコードが冗長化しそうです。スリムなコードにするにはどうしたら良いでしょうか? よろしくお願いします^^ ' ///Sheet1/// Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim time7 As Range For Each time7 In Target If time7.Column = 1 Then time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _ Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM") End If Application.EnableEvents = False Application.EnableEvents = True Next time7 '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 ws2.Range("A3:E3").Value = ws1.Range("A3:E3 ").Value Set ws1 = Nothing Set ws2 = Nothing End Sub Private Sub Worksheet_Activate() ' ' 新規行挿入 ' ' Worksheets("Sheet2").Range("3:3").Insert Sheets("Sheet1").Range("H3").Select ActiveCell.FormulaR1C1 = "5" Sheets("Sheet1").Range("E3").Select Selection.ClearContents Dim str_Left As String 'セルE4に文字列、セルH4に数字を予め入れておくこと。 str_Left = Left(Cells(4, 5), Cells(4, 8)) MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!" Sheets("Sheet1").Range("A3").Select Dim se_r As String se_r = Application.InputBox("バーコードを入力してください") Select Case se_r Case "False" MsgBox "キャンセルされました" Case "" MsgBox "空欄が入力されました" Case Else Range("A3").Value = se_r End Select End Sub ' ///Sheet2/// Private Sub Worksheet_Activate() Dim Emp(1 To 300) As String Dim msg As String Dim i, i2, Cnt As Integer Dim N_In As Variant For i = 3 To 3 If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定 Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理 End If Application.EnableEvents = True '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Dim st1, s, i3 As Long Dim Bst As Range Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 st1 = ws1.Cells(Rows.Count, "E").End(xlUp).Row 'A列の最終行を設定する s = 3 For i3 = 3 To st1 Set Bst = ws2.Columns("E").Find(What:=ws1.Cells(i3, "E"), LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) 'A列とE列を比較 If Bst Is Nothing Then '比較して無い場合は、下記を実行 ws2.Cells(s, "A") = ws1.Cells(i3, "A") '追加する文字を転記する。(コード) ws2.Cells(s, "C") = Mid(ws1.Cells(i3, "A"), 3, 5) '追加する文字を転記する。(コード2) s = s + 1 End If Next i3 'A列データの最終行までループ Next i ws2.Range("C3:C300").Replace What:="01777", Replacement:="NAME1", LookAt:=xlPart, MatchCase:=True ws1.Range("C4").Value = ws2.Range("C3").Value ws1.Activate Set ws1 = Nothing Set ws2 = Nothing End Sub

共感・応援の気持ちを伝えよう!

  • 回答数3
  • 閲覧数74
  • ありがとう数5

みんなの回答

  • 回答No.3
  • kkkkkm
  • ベストアンサー率58% (893/1526)

> もっと努力なり才能なりがあれば、エラーを正確に検出出来たのですが、、。 エラーメッセージとVBAの止まった箇所(確か黄色で反転してる)でほとんどの場合はわかると思います。 > 確かなのは置換しないと入力作業に負担が行きます。基本的に1・2・3で入力出来ればなと思っています。 1を入力したら山田太郎に置換 2を入力したら田中一郎に置換 3を入力したら吉田茂に置換 以下50とか100とかある感じでしょうか 数字毎に対応した別表が必要になります。大量になればその対応表を覚えるのが大変かも。 > 表形式にまとめる→必要箇所だけ抜き取る(保存する) 新しいブックに必要なシート(シートに不要な部分があれば範囲)をコピーして保存する。

共感・感謝の気持ちを伝えよう!

質問者からの補足

小規模な話しなので使うのはせいぜい全部で20~30項目です。使うか使わないか分からないのが倍以上あるかも知れないけれど、です。細かく別けるとそんな感じです。中規模なれば100項目以上かも知れませんが、、。作るにあたり、データに何かあっても大丈夫なのから数値化しようとしてますが、、ただ何かなくても保存は出来るようにしたいです。また、日に50~100も入力すれば済むものですが、その項目コードの細分化も難しいというか規模こそではあって対応コードにするのは一工夫要ります。 日別、週間、月間、、過去履歴を閲覧できるデータベース仕様のに落とし込めれば完成ですが、長い話しですね。 特徴あるというか、我ながらな作りにできれば利用価値はあるかな。。

関連するQ&A

  • エクセルの簡単なマクロ機能を追加したいのです

    既存のエクセルマクロ(Sub チェック()以下です)に下記の内容のマクロを付け足したいです。 教えていただけないでしょうか。 付け足したい条件です:  Sheet2のC列に 0  があれば  Sheet1のB列に 愛 と([太字]でセルの背景色を[灰色25%]にして)入れたいです 恐れ入りますがご存じの方がいらっしゃりましたら教えていただきたく何卒よろしくお願いいたします。 ----------------------------------------------- Sub チェック() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If c2.Offset(, 1).Value = "" Then c1.Offset(, 1).Interior.ColorIndex = 3 Else c1.Offset(, 1).Value = c2.Offset(, 1).Value End If myCt = myCt + 1 End If Next c2 If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub

  • カットして隣のB列に順番にペーストするマクロ

    発注と納品の確認マクロを作成しました。 Sheet1の列を検索して、Sheet2にあればその数字のあるセルを赤くするのですが、 それを以下のように変更することは可能でしょうか? Sheet1の列を検索して、Sheet2にあれば、Sheet2上でその数字をカットして隣のB列に上から順番にペーストします。 宜しくお願いします。 Sub 発注と納品の確認マクロ() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If myCt = 0 Then c2.Interior.ColorIndex = 3 Else c2.Interior.ColorIndex = 43 End If myCt = myCt + 1 End If Next c2 If myCt = 0 Then c1.Interior.ColorIndex = 6 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub

  • ExcelのVBAについてです。シート1と2を作成

    ExcelのVBAについてです。シート1と2を作成し、シート1にバーコードまたはキーボードで入力します。シート1は入力専用かつ入力した分の早見表で、実際にはシート2に転記仕訳して、シート3以降に表を作成したいです。使い方はシート1に入力またはシート2をタップまたはクリックすると入力(画面)になります。以前の質問の回答を参考に必要最低限に改良しています。パッと見で構いません、何か不具合は見付からないでしょうか? '///Sheet1/// Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim time7 As Range For Each time7 In Target If time7.Column = 1 Then time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _ Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM") End If Application.EnableEvents = False Application.EnableEvents = True Next time7 '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 ws2.Range("A3:H3").Value = ws1.Range("A3:H3 ").Value End Sub Private Sub Worksheet_Activate() ' ' 新規行挿入 ' ' Worksheets("Sheet2").Range("3:3").Insert Sheets("Sheet1").Range("H3").Select ActiveCell.FormulaR1C1 = "5" Sheets("Sheet1").Range("E3").Select Selection.ClearContents Dim str_Left As String 'セルE4に文字列、セルH4に数字を予め入れておくこと。 str_Left = Left(Cells(4, 5), Cells(4, 8)) MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!" Sheets("Sheet1").Range("A3").Select Dim se_r As String se_r = Application.InputBox("バーコードを入力してください") Select Case se_r Case "False" MsgBox "キャンセルされました" Case "" MsgBox "空欄が入力されました" Case Else Range("A3").Value = se_r End Select End Sub ' ///Sheet2/// Private Sub Worksheet_Activate() Dim Emp(1 To 300) As String Dim msg As String Dim i, i2, Cnt As Integer Dim N_In As Variant For i = 3 To 3 If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定 Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理 End If '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Dim st1, s, i3 As Long Dim Bst As Range Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 st1 = ws1.Cells(Rows.Count, "E").End(xlUp).Row 'A列の最終行を設定する s = 3 For i3 = 3 To st1 Set Bst = ws2.Columns("E").Find(What:=ws1.Cells(i3, "E"), LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) シート間のE列を比較 If Bst Is Nothing Then '比較して無い場合は、下記を実行 ws1.Cells(s, "A") = ws1.Cells(i3, "A") '追加する文字を転記する。(コード) s = s + 1 End If Next i3 Next i '(1)シートを変数にセット Dim ws1_ As Worksheet Set ws1_ = Worksheets("Sheet1") ws1_.Activate End Sub

  • 回答No.2
  • kkkkkm
  • ベストアンサー率58% (893/1526)

> 9401777→01777→NAME1 > という元の文字列から取得(01777)→置換(NAME1)をしたコード このコードがかなりの回数実行される(回数分記載する)のを回避したいということでしたら 先に書いたように実数を変数に入れてループするという処理になると思います。 > 今のところ固定的に発現してくるので問題としていません。 一定の操作でエラーになるのでしたら、原因は分かりやすいと思いますが、問題としていないという事ですので第三者が口をはさむこともないみたいですし、その操作をしなければいいだけという事になりそうですね。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

CSV形式等でファイルに保存できれば、次は別のコードでとも考えています。 入力→『表形式にまとめる→必要箇所だけ抜き取る(保存する)』→別のコードで… 今回の繰り返し質問は『』内の質問になります。 またシート1とシート2に分けていますが、別のコードにすることで、、シート1が入力画面兼表形式でシート2が作業シートにしようかと思っています。

質問者からの補足

もっと努力なり才能なりがあれば、エラーを正確に検出出来たのですが、、。 ある数字の文字列には一意の文字列を付ける予定です。 B列 1→名前1 2→名前2 3→名前3 … さらに C列 101→ストレッチ 102→ウォーキング 103→ランニング … 等のような。 D列も使えるのですが、、VBAのコードばかりでなく、バーコードの方で調整できないか思案してます。 確かなのは置換しないと入力作業に負担が行きます。基本的に1・2・3で入力出来ればなと思っています。

  • 回答No.1
  • kkkkkm
  • ベストアンサー率58% (893/1526)

> 試作だけにコードの見映えがよくありません どの部分でしょうか。すべてにおいてということでしょうか。 > 何十何百となった時に 「4901777」の数字が何十何百となったときということでしょうか。 としたら どこかのシートのX列に数字のデータを何十何百と入れておいて (NAME1が変化するのでいたらそちらを対象に変更して) For i = 1 To Cells(Rows.Count, "X").End(xlUp).Row Fstr = どこかのシート.Cells(i, "X").Value ws2.Range("C3:C300").Replace What:=Fstr, Replacement:="NAME1", LookAt:=xlPart, MatchCase:=True Next 前回 Set ws1 = Nothing とオブジェクトを解放する癖をつけておいた方がいいとだけしか書かなくて説明不足だったのでここで追記させてください。 最後までオブジェクトを解放していない場合、(Set ws1 = Nothingがない場合) End Sub で解放されるので、実際最後までオブジェクトを利用している場合は Set ws1 = Nothing を記載しなくてもほとんど問題は無いと思います。記載していると無駄だと指摘されるかもしれません。 ただ、処理によってはオブジェクトを利用しなくなって「すぐ」に解放しないと不都合が起こる可能性があります。そのために、解放する癖をつけておいた方がいいですよ、という説明になりました。 あと。、余計なお世話かもしれませんが、問題がありそうなコードで次々と機能を追加していくと、エラーが出たときにどこが問題なのか見つけるのに苦労すると思いますよ。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

9401777→01777→NAME1 という元の文字列から取得(01777)→置換(NAME1)をしたコードですが、、というのです。この部分のコードについてでした。 完成形からすれば、せめてコードはキレイに書くべきですね。また、修正が必要な箇所が最低1箇所あります。よく分からないエラー擬が1つほどあります。他にもExcelが動作不良になる場合も。その為ではないですが、色々試行錯誤しながらコードを追加しています。エラーの出方や特徴も知りたいですし、、。 今のところ固定的に発現してくるので問題としていません。理由等々分かれば書き直すのですが、、。 繰り返しの質問に回答ありがとうございます。

質問者からの補足

参考になります。ありがとうございます^^ 完成されたコードを目指していたら、全てにおいてでしょう。しかし、コードの問題よりは、生産性的に効率よく書けるだけで良いです。最終的には整理して分類してスマートな記述を目指してなどになりますが、一旦完成形にすると、、それ以上を必要としないとは思います。生産性的に必要以上のコードは要らないと思いますから、、。 目につく辺りはあると思いますが、そこに可能性があると信じています。間違いもあるが? そんな感じですが、考えている内容の違いと思ってください。 回答参考にさせてもらいます。

関連するQ&A

  • ExcelのVBAについて(勉強中のです。)

    ExcelのVBAについて(勉強中のです。) ここからコード3以降に入力したコードを抜き出してデータ表を作成しそれを保存するコードを作成したいです。例えばCSV形式にするとか? データ表は1日分の表示で、保存して週間や月間または統計データまでを視野にいれています。今回は保存する所です。。 利用しやすい状態と保存形式で、よろしくお願いします。データは生活記録みたいなものです。何したどうしたどうなった? ※大分分岐する予定で、作成中であり、今回はコードの整理は不要です。 '///Sheet1/// Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim time7 As Range For Each time7 In Target If time7.Column = 1 Then time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _ Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM") End If Application.EnableEvents = False Application.EnableEvents = True Next time7 '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 ws2.Range("A3:H3").Value = ws1.Range("A3:H3 ").Value End Sub Private Sub Worksheet_Activate() ' ' 新規行挿入 ' ' Worksheets("Sheet2").Range("3:3").Insert Sheets("Sheet1").Range("H3").Select ActiveCell.FormulaR1C1 = "5" Sheets("Sheet1").Range("E3").Select Selection.ClearContents Dim str_Left As String 'セルE4に文字列、セルH4に数字を予め入れておくこと。 str_Left = Left(Cells(4, 5), Cells(4, 8)) MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!" Sheets("Sheet1").Range("A3").Select Dim se_r As String se_r = Application.InputBox("バーコードを入力してください") Select Case se_r Case "False" MsgBox "キャンセルされました" Case "" MsgBox "空欄が入力されました" Case Else Range("A3").Value = se_r End Select End Sub ' ///Sheet2/// Private Sub Worksheet_Activate() Dim Emp(1 To 300) As String Dim msg As String Dim i, i2, Cnt As Integer Dim N_In As Variant For i = 3 To 3 If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定 Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理 End If Next i '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") ws1.Activate End Sub

  • エクセルでのマクロを使った参照

    教えてください。 シート1のB23:F73のデータをシート2に張りつけたいのですが、 その際にB列には連番で1~50の数字が入っており C、D列にはデータが有る場合とない場合があります。 データがある場合は必ず対で存在します。 貼り付けの際にC、D列にデータのある行のみ B、C、D列のデータを連続で並ばせたいのですが、 どのようにマクロを組んだらよろしいですか? 手元に資料もなく、困ってしまいました。 よろしくお願いします。 現在のマクロは以下の通りです Sub TEST4() Dim S1 As Worksheet, S2 As Worksheet Set S1 = Worksheets("SHEET1") Set S2 = Worksheets("SHEET1") S2.Range("A1:E51").Value = S1.Range("B23:F73").Value End Sub

  • エクセルで在庫表を作ろうとしています

    エクセルで在庫表を作ろうとしているのですが、躓いてしまって困っています。 TEST1 コードを手入力した後実行 TEST2 出庫数を入力した後実行 Option Explicit Option Base 1 Sub TEST1() 'コードを手入力した後実行 Dim ws1 As Worksheet Dim ws2 As Worksheet Dim r&, i& Dim vL1 As String Dim vL2 As Long Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") r = ws1.Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To r vL1 = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1), ws2.Range("A2:IV65536"), 2, False) ws1.Cells(i, 1).Offset(, 1) = vL1 vL2 = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1), ws2.Range("A2:IV65536"), 3, False) ws1.Cells(i, 1).Offset(, 2) = vL2 Next i End Sub Sub TEST2() '出庫数を入力した後実行 Dim ws1 As Worksheet Dim ws2 As Worksheet Dim r&, i& Dim vL2 As Long Dim vL3 As String Dim syukko As Long Dim fnd As Range Dim zaiko As Long Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") r = ws1.Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To r If ws1.Cells(i, 4) > 0 Then syukko = ws1.Cells(4, 1).Offset(, 3).Value vL2 = Application.WorksheetFunction.VLookup(ws1.Cells(3, 2), ws2.Range("A2:IV65536"), 3, False) Set fnd = ws2.Range("A:A").Find(ws1.Cells(i, 1)) If fnd Is Nothing = False Then zaiko = vL2 - syukko fnd.Offset(, 2) = zaiko End If MsgBox ws1.Cells(i, 2) & "を" & syukko & "出庫します" & vbLf & "在庫は" & zaiko & "になります。" Else MsgBox "出庫数を入力して下さい" Exit Sub End If Next i ws1.Range("A2:D65536").ClearContents End Sub ここまでは作りました。 ですが、プロシージャの外では無効です と出てしまいます。 どうすればよいのでしょうか。 教えて下さい。 シート1のB2にコード・C3に名前・D2に現在個数・E2に出庫数を入力します。 実際にはB3からすうじを入力し、コードを入力すれば自然に名前と現在個数を シート2から探してくるようにしたいです。 シート2にはA列にコード、B列に名前、C列に現在庫数が載っている表があります(量が半端ではないです) 出来れば、1度出庫数を入れたら、次開いた時にシート2のC列にある現在個数が自然に減っていて、シート1にはフォームしか残らない状態にしたいです。 お願いします<m(__)m>

  • シート1の氏名をシート2に反映

    sheet1の氏名をsheet2の日付、記号(A,B,C)にマッチした位置に入力させたいのですが下記コードで他で試したのですがうまくいきません。どなたかコードが解る方よろしくお願いします。 Sub 入力() Dim i As Long, j As Long, k As Long, L As Long Dim wS1 As Worksheet, wS2 As Worksheet Set wS1 = Worksheets("Sheet1") Set wS2 = Worksheets("Sheet2") i = wS2.Range(wS2.Cells(6, 1), wS2.Cells(8, 1)) j = wS2.Cells(3, Columns.Count).End(xlToLeft).Column Range(wS2.Cells(3, 2), wS2.Cells(i, j)).ClearContents On Error Resume Next For i = 2 To wS1.Cells(Rows.Count, 4).End(xlUp).Row If WorksheetFunction.CountA(wS1.Rows(i)) > 1 Then For j = 2 To wS1.Cells(i, Columns.Count).End(xlToLeft).Column If wS1.Cells(i, j) <> "" Then k = WorksheetFunction.Match(wS1.Cells(i, 4), wS2.Range(wS2.Cells(6, 1), wS2.Cells(8, 1)), False) L = WorksheetFunction.Match(wS1.Cells(5, j), wS2.Rows(3), False) wS2.Cells(k, L) = wS1.Cells(i, j) End If Next j End If Next i End Sub

  • エクセル2003にて指定されたシートを複写するには?(2)

    エクセル2003にて指定されたシートを複写するには?(2) 同じ件で投稿してすみません。エクセル本を読んでも、ネットで探しても 丸2日進んでいないので、投稿させて頂きました。 以前、以下のURLで投稿したものです。 http://okwave.jp/qa/q5930740.html 【回答して頂いた内容】 Sub aaa() Dim Ws1 As Worksheet, Ws2 As Worksheet Set Ws1 = Worksheets("シート1") Set Ws2 = Worksheets("シート2") Dim Endrow As Long, r As Integer Endrow = Ws1.Cells(Rows.Count, 1).End(xlUp).Row For r = 1 To Endrow     Worksheets.Add After:=Worksheets(Worksheets.Count)    ActiveSheet.Name = Ws1.Cells(r, 1).Value    Cells(5, 1).Value = Ws1.Cells(r, 1).Value    Cells(5, 2).Value = Ws1.Cells(r, 2).Value    Cells(5, 3).Value = Ws1.Cells(r, 3).Value Next r Set Ws1 = Nothing Set Ws2 = Nothing End Sub と、ご回答を頂き、想定していた対応が出来ていますが、 問題が2つほどございます。 (1)ひとつは、シート名及びテキストをA列ではなく、J列から持ってくる必要がある。 (2)もうひとつは、1行目はタイトル行なので、2行目から開始する必要がある。 この2点を解消しようと、色々数字を入れて試したのですが、改善できないので、 どなたか、是非、アドバイス・ご享受を宜しくお願い申し上げます。

  • エクセル マクロの設定方法について

    差込印刷でSheet1に作成した名簿データにより、sheet2に作成しているデータへ差込印刷をしています。現在、次のようなマクロを組んで名簿の件数に合わせて、For = 2 To 500 Step 8を修正しながら、印刷しています。できたら、名簿の件数の増減に関係なく印刷できるようになればと考えています。始めたばかりのマクロ初心者です。よろしくご教授ください。お願いします。 Dim i As Long Dim ws1 As Worksheet, ws2 As Worksheet Set ws1 = sheets(″sheet1″) Set ws2 = sheets(″sheet2″) For i = 2 To 500 Step 8 ws2 .Range(″A1″).Value = ws1.Cells(i+1,2).Value ws2 .Range(″A7″).Value = ws1.Cells(i+2,2).Value ws2 .Range(″A13″).Value = ws1.Cells(i+3,2).Value ws2 .Range(″A19″).Value = ws1.Cells(i+4,2).Value ws2 .Range(″F1″).Value = ws1.Cells(i+5,2).Value ws2 .Range(″F7″).Value = ws1.Cells(i+6,2).Value ws2 .Range(″F13″).Value = ws1.Cells(i+7,2).Value ws2 .Range(″F19″).Value = ws1.Cells(i+8,2).Value DoEvents ws2.PrintOut Next End Subws2 .Range(″F1″).Value = ws1.Cells(i+5,2).Value ネット等で調べて、上記のようなマクロで作業してます。(マクロの設定方法が間違っているところがあると思いますが?)

  • エクセルのVBAの記述について

    VBAの記述についてなのですが、 Sub filter() Dim gyo As Long Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Set ws1 = Worksheets("データ") Set ws2 = Worksheets("チーム") Application.ScreenUpdating = False ws2.Range("A4:BH30").Clear gyo = ws1.Range("A65536").End(xlUp).Row ws1.Activate With ws1.Range(Cells(4, 1), Cells(gyo, 6)) .AutoFilter Field:=1, Criteria1:="A" .SpecialCells(xlCellTypeVisible).Copy ws2.Range("A4") Selection.AutoFilter End With Application.ScreenUpdating = True End Sub ならプログラムははしるのですが、 14行目を .SpecialCells(xlCellTypeVisible).Copy ws2.Range(Cells(4, 1)) だと 「実行時エラー 1004 Rangeメソッドは失敗しました Worksheet オブジェクト」 とでるのですが、出来ないのでしょうか? Cells(4, 1)の1のところを変数にして変えていきたいのですが、よい方法はありますか。 よろしくお願いいたします。

  • COUNTIFS関数をVBAで使用したい

    お世話になります。 よろしくお願いいたします。 Sheet1に集計表、Sheet2にデーターがあります。 氏名とコードが合致するデーターの個数を出したいのですが、コードの書き方がわかりません。 ご教示をお願いいたします。 Sheet1のB列の最後に小計や合計が入っているため、A列使用。 COUNTIFS関数でコンパイルエラーがでます。 Sheet1 A    B   C    D 氏名 氏名 コード 合致する個数 Sheet2 B    J     N 氏名  コード   数値 Sub test1() Dim i As Long, t As Long Dim wS1 As Worksheet, wS2 As Worksheet Set wS1 = Worksheets("Sheet1") Set wS2 = Worksheets("Sheet2") i = wS1.Range("A" & Rows.Count).End(xlUp).Row t = wS2.Range("B" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False For i = 5 To i Range(wS1.Cells(5, "D"), wS1.Cells(i, "D")).Formula = _ "=COUNTIFS(wS2.Range("B7:B"&t),B5,wS2.Range("J5:J"&t),C5)" Next i Application.ScreenUpdating = True End Sub

  • ExcelVBA一致しない場合その他の行に集計する

    「ExcelVBA複数条件一致後別シートに結果表示」という質問を以前させていただき、丁寧にコードを解説していただきました。 ※その節はありがとうございました。 ●ファイルの内容(概要)配下の通りの構成です。  <Sheet1>   A列:性別(男性:1、女性:2でコード化)   B列:死因コード(数値5&#65374;6桁)   C列:年齢   D列:市町村(3桁でコード化「201」等)  <Sheet2>Sheet1で条件に一致したものを以下の通り表を作成する   ・「セルA1」に表にしたい市町村コードをあらかじめ入力しておく   ・セルB1&#65374;セルEC1まで死因コード   ・セルA2&#65374;セルA132まで年齢0&#65374;130   ・セル範囲B2&#65374;EC132に「A1」に入力した市町村コードの男性の値が入る   ・セルB133&#65374;セルEC133まで死因コード   ・セルA134&#65374;A264まで年齢0&#65374;130   ・セル範囲B134&#65374;EC264に「A1」に入力した市町村コードの女性の値が入る そして、以下のコードを教えていただきました。 **************************************************** Dim r As Long Dim i As Integer, j As Integer, k As Integer Dim Wsf As Object Dim SCode As Range, Nenrei As Range Dim Ws1 As Worksheet, Ws2 As Worksheet Set Ws1 = Worksheets("sheet1") Set Ws2 = Worksheets("sheet2") Set Wsf = Application.WorksheetFunction Application.ScreenUpdating = False Ws2.Range(Ws2.Cells(2, 2), Ws2.Cells(132, 133)).ClearContents Ws2.Range(Ws2.Cells(134, 2), Ws2.Cells(264, 133)).ClearContents With Ws2 Set SCode = .Range(.Cells(1, 1), .Cells(1, 133))  ↑ここはこのように書いていただいたのから、  指定の死因分類があったためシートから参照するようコードを変えています。  手元にファイルが無くてかけないのが初心者の情けないところです。  申し訳ありません。※シートは同一ファイル内におくようにしています。 End With r = 2 Do While Ws1.Cells(r, 1).Value <> "" If Ws1.Cells(r, 4).Value = Ws2.Cells(1, 1).Value Then If Ws1.Cells(r, 1).Value = 1 Then i = 1 ElseIf Ws1.Cells(r, 1).Value = 2 Then i = 134 End If With Ws2 Set Nenrei = .Range(.Cells(i, 1), .Cells(i + 130, 1)) End With j = i + Wsf.Match(Ws1.Cells(r, 3).Value, Nenrei, 0) - 1 k = Wsf.Match(Ws1.Cells(r, 2).Value, SCode, 0) Ws2.Cells(j, k).Value = Ws2.Cells(j, k).Value + 1 Else End If r = r + 1 Loop Application.ScreenUpdating = True Set Scode = Nothing Set Nenrei = Nothing Set Wsf = Nothing Set Ws1 = Nothing Set Ws2 = Nothing End Sub **************************************************** 表はあらかじめ作成しておくので、そこに集計結果が入ります。 実行していたら、古いファイルに不詳の死因コードが登場し、 どうしたらいいかと考えた結果、死因コードの列の最後に「その他」を設け、 死因コードに一致しない場合にはそこに集計結果をカウントすることは できないか?という考えに至りました。 自分で考えるのが一番勉強になると分かっていても試行錯誤している時間が無く、 急ぎのためお知恵のある方々にご協力を頂ければと思い、 再度質問させていただいた次第です。 前の質問は↓こちらです。 http://okwave.jp/qa/q8356291.html 何卒よろしくお願い申し上げます。

  • Excel 2007 マクロ 別シートの情報を反映する方法

    Excel 2007 マクロ 別シートの情報を反映する方法 Sheet1とSheet2があります。 Sheet1のD列とSheet2のM列で同じ値があれば、 Sheet1のE列の値をSheet2のN列に反映するマクロを 作成しました。 下記が正しいと思っていたのですが、エラーメッセージは出ずに 値が反映されません。 マクロに問題点があればご指摘ください。 よろしくお願いいたします。 Sub Rist() Dim i, j As Long Dim ws1, ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") For i = 2 To ws1.Cells(Rows.Count, "D").End(xlUp).Row For j = 2 To ws2.Cells(Rows.Count, "M").End(xlUp).Row If ws2.Cells(j, "M") = ws1.Cells(i, "D") Then ws2.Cells(j, "N") = ws1.Cells(i, "E") End If Next j Next i End Sub