• ベストアンサー
  • 困ってます

VBA sheet2データーから平均取得 sheet1へコピー

sheet2指定セルデーターから平均 sheet1指定セルに取得したいのですがうまくいきません。 例 sheet1       sheet2 列A  列B 列C  列A  列B 列C 1  2 指定  1  2  3 1  2  3   1  2  3 1  2  3   1  2  3 sheet2・列C1~3の平均を、sheet1・指定セルに取得したいのですが Sub test() Dim r As Long, u As Long, ws1 As Object, ws2 As Object, y As Long r = 10 u = 1 Set ws1 = Sheets(1) Set ws2 = Sheets(2) y = ws1.Range("A" & Rows.Count).End(xlUp).Row Dim myAve As Long myAve = Application.WorksheetFunction.Average(ws2.Range(Cells(3, u), Cells(7, u))) ws1.Cells(r, 7).Value = "myAve" r = r + 1 u = u + 1 End Sub 変数y r u を使いfor~nextでデーターを一括取得するつもりなのですが この段階でうまくいきません。

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

  • 回答数2
  • 閲覧数135
  • ありがとう数3

質問者が選んだベストアンサー

  • ベストアンサー
  • 回答No.1

>ws1.Cells(r, 7).Value = "myAve" 変数の使用方法が間違っています ws1.Cells(r, 7).Value = myAve >変数y r u を使いfor~nextでデーターを一括取得するつもりなのですが う~ん、コードからは読み取れませんし、for~nextを使用するような内容でも無いと思います 質問のコードをなるべく使用すると Sub test() Dim r As Long, ws1 As Object, ws2 As Object, y As Long r = 10 Set ws1 = Sheets(1) Set ws2 = Sheets(2) y = ws2.Range("C" & Rows.Count).End(xlUp).Row ws1.Cells(r, 7).Value = Application.WorksheetFunction.Average(ws2.Range(ws2.Cells(1, 3), ws2.Cells(y, 3))) End Sub こんな感じ

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

質問者からのお礼

どうもありがとうございました。 (ws2.Range(Cells(3, u), Cells(7, u))) (ws2.Range(ws2.Cells(3, u), ws2.Cells(7, u))) に直し ws1.Cells(r, 7).Value = myAve に、直した結果できました。 >う~ん、コードからは読み取れませんし、for~nextを使用するような内容でも無いと思います このような感じにしたいと思いfor~nextかなと思ったのですが。 sheet2 http://www.geocities.jp/gimonyou01/ws4.jpg sheet1 http://www.geocities.jp/gimonyou01/ws3.jpg VB http://www.geocities.jp/gimonyou01/ws2.jpg

関連するQ&A

  • EXCELでSheetにデータを蓄積したい

    Sheet1に入力シートを作成し、Sheet2に蓄積シートを作成しました。 Sheet1で作成されたデータをSheet2に蓄積させておきたい。 Sheet1のA2の値が入力された場合に実行するとすると Sheet1のデータ数は、毎回異なります。 他を参考に以下のように作ってみたのですが、 Private Sub Worksheet_Change(ByVal Target As Range) Dim lastA As Long, lastB As Long, ws1 As Worksheet, ws2 As Worksheet Set ws1 = Sheets("入力シート") Set ws2 = Sheets("蓄積シート") With Target If .Address <> "$A$2" Or .Count <> 1 Or IsEmpty(Target) Then Exit Sub If WorksheetFunction.Count(ws1.Range("a1:s1")) <> 19 Then Exit Sub lastA = ws2.Range("a65536").End(xlUp).Row lastB = ws1.Range(("a2:s2"), Selection.End(xlDown)).Select ws2.Range("a" & lastA + 1).Resize(1, 19).Value = _ ws1.Range("a2:S2").Resize(1, 19).Value End With End Sub 'ws1.Range("a2:S2").Resize(1, 19).Value の部分で '上記ws1の範囲の内、Row2の値しかws2へ反映されません どなたか教えて頂けないでしょうか。

  • 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

  • excel2003入力したデータを別シートにコピー

    会社でエクセル2003を使っています。 ド素人で、専門用語が全く分からないのでお許しください。 ひな形に入力したデータを その都度、別シートにリストとして保存したいのです。 ネットで調べたところマクロを使うようで Sub 正方形長方形4_Click() Call macro01 Call macro02 End Sub Sub macro01() Dim ws1 As Worksheet, ws2 As Worksheet Dim x As Long, y As Long Set ws1 = Sheets("Sheet1") Set ws2 = Sheets("Sheet2") x = ws2.Cells(Rows.Count, "b").End(xlUp).Row + 1 y = ws1.Cells(Rows.Count, "b").End(xlUp).Row ws1.Cells(21, "b").Resize(y, 9).Copy ws2.Cells(x, "B").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False End Sub Sub macro02() Worksheets("Sheet1").PrintOut End Sub いろいろ知らべみてこのようなマクロを作りました。 家のエクセル2010では順番に入力行のその下にデータリストが増えていくのですが 会社の2003だと2行空いてしまうのです。 上記にマクロは家で作って会社ではそのマクロを入力する形です。 マクロの意味が全く分からず、どこを修正すればいいのかもわかりません。 お力をお貸しください。 よろしくお願いいたします。

その他の回答 (1)

  • 回答No.2

>このような感じにしたいと思いfor~nextかなと思ったのですが。 リンク先を見て分りました '簡単な解説とチョッと修正 Sub test() 'Dim r As Long, u As Long, ws1 As Object, ws2 As Object, y As Long '変数の宣言をまとめました Dim ws1 As Worksheet, ws2 As Worksheet Dim myAve As Long Dim r As Long, u As Long Dim i As Long, y As Long 'r = 10   'アへ 'u = 1    'イへ Set ws1 = Sheets(1) Set ws2 = Sheets(2) y = ws1.Range("A" & Rows.Count).End(xlUp).Row 'Dim myAve As Long  ’変数の宣言は、まとめた方が良いです 'Dim i As Long For i = 10 To y r = i    'ア u = r - 9  'イ myAve = Application.WorksheetFunction.Average(ws2.Range(ws2.Cells(3, u), ws2.Cells(7, u))) ws1.Cells(r, 7).Value = myAve 'r = r + 1  ’アとすることで不要になります 'u = u + 1  ’イとすることで不要になります Next i End Sub '私ならこうするかな 'rとuの差が常に9なので 'r=i、u=i-9に、それぞれ置き換えることにより 'for~nextの部分がスッキリするかと思います Sub test_2() Dim ws1 As Worksheet, ws2 As Worksheet Dim i As Long Set ws1 = Sheets(1) Set ws2 = Sheets(2) For i = 10 To ws1.Range("A" & Rows.Count).End(xlUp).Row ws1.Cells(i, 7).Value = Application.WorksheetFunction.Average(ws2.Range(ws2.Cells(3, i - 9), ws2.Cells(7, i - 9))) Next i End Sub 以上、参考まで

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

質問者からのお礼

どうもありがとうございました。 i= がある以上r.uは不要でしたね。

関連するQ&A

  • 正規表現でデーター取得

    Webクエリで株価取得しようマクロを作ったのですが IE7を使用しているので、出来ないことが分かり 正規表現にて取得しようとしてみましたが うまく取得できません。 http://www.technobahn.com/apps/fn/quote?r=3m&c=1412&s=medium&color=&lang= 上記リンク先の始値~相場全体までのデータを 取得したいのですが・・・ とりあえずは、取得したデータをsheet2.A列に入れてみたのですが 文字化けに関係のないデータまでもを取得しています。 sheet1  A     コード Const vaa As String = "Ver1.02" Const URLI As String = "http://www.technobahn.com/apps/fn/quote?r=3m&c=" Dim urlweb As String 'Web接続先 Dim code As String '銘柄コード Sub 株価取得() Dim oHttp As Object, ws1 As Object, ws2 As Object Dim dthtml As String Dim chktb As String Dim stchk1 As Long Dim stchk2 As Long Dim chksu As Long Dim j As Integer Dim urlweb As String Dim mino As Long, w As Long Set ws1 = Sheets(1) Set ws2 = Sheets(2) w = 1 mino = ws1.Cells(w, 1) urlweb = URLI & "mino" Set oHttp = CreateObject("Microsoft.XMLHTTP") oHttp.Open "GET", urlweb, False oHttp.Send dthtml = oHttp.responsetext With CreateObject("VBScript.RegExp") .Pattern = ">([^<>]+)<" .Global = True On Error Resume Next stchk1 = InStr(dthtml, "始値") stchk2 = InStrRev(Left(dthtml, stchk1), "table") chksu = InStr(stchk2, dthtml, "</table") dthtml = Mid$(dthtml, stchk2, chksu) itmsu = .Execute(dthtml).Count ReDim hdat(itmsu) With .Execute(dthtml) For j = 1 To itmsu ws2.Cells(j, 1) = .Item(j).SubMatches(0) Next j End With On Error GoTo 0 End With Set oHttp = Nothing DoEvents End Sub

  • VBA 別シートからコピー貼付け(複数列)

    別シートからコピー貼付け(複数列)をしたいのですが,同一シートからのコピー貼付けはネットから以下のマクロでできました。 しかし,別シートsheet1からsheet2ヘコピーで修正しましたが,「アプリケーション定義またはオブジェクト定義のエラーです。」となります。どなたかご教授よろしくお願いします。 修正したマクロ Sub sampel() Dim i As Long For i = 2 To Range("E65536").End(xlUp).Row Step 2 Sheets("sheet2").Range(Cells(i + 1, 2), Cells(i + 1, 85)).Value = _ Sheets("sheet1").Range(Cells(i, 5), Cells(i, 88)).Value Next i End Sub 参考としたマクロ http://www.excel.studio-kazu.jp/kw/20041208152106.html Sub sampel() Dim i As Long For i = 2 To Range("E65536").End(xlUp).Row Step 2 Range(Cells(i + 1, 2), Cells(i + 1, 85)).Value = _ Range(Cells(i, 5), Cells(i, 88)).Value Next i End Sub

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

    差込印刷で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の検索について質問です。 以下のようなものを作ろうと思います。 sheet1とsheet2がありsheet1のA、Bの数値をsheet2の同じA,Bの数値の値の行を検索して, その同じ値の行のsheet1のCの数値の値からsheet2のCの数値を引いた値をsheet3のC列に返すプログラムを作ろうと思います。空白などで同じ値がない場合はsheet3に空欄を返そうと思います。 以下に例をプログラムの実行例を示します。 sheet1 ■ A 列 B 列 C列 1: 7 | 1 | 3 2: 5 | 8 | 2 3: 2 | 3 | 1 4: 9 | 6 | 4 sheet2 ■ A 列 B列 C列 1: 2 | 3 | 4 2: 9 | 6 | 2 3: 7 | 1 | 5 4: 5|   | 3 sheet3 ■ A列 B列 C列 1: 7| 1 | -2 2: 3: 2| 3 | -3 4: 9 | 6 | 2 自分で以下のプログラムを作成してみたのですが空欄が検索できなかったりしてなかなかできません。 どなたか、教えてください。お願いします。 Sub test() Dim sh1 As Object, sh2 As Object, sh3 As Object Dim d1 As String, d2 As String, a As Long Set sh1 =Sheets(“Sheet1”) Set sh2 =Sheets(“Sheet2”) Set sh3 =Sheets(“Sheet3”) For a = 1 To 3000 Step 1 d1 = sh1.Cells(a,1) & sh1.Cells(a,2) d2 = sh2.Cells(a,1) & sh2.Cells(a,2) Do while d2 <>”” If d1 = d2 Then Sh3.Cells(a,1) = sh1.Cells(a,1) Sh3.Cells(a,2) = sh1.Cells(a,2) Sh3.Cells(a,3) = sh1.Cells(a,3) Exit Do End If a= a+1 d2 = sh2.Cells(a,1) & sh2.Cells(a,2) Loop Next End Sub

  • シート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

  • Excel VBA 連番印刷

    昨日以下の質問をさせていただいた者です。 http://okwave.jp/qa/q8349562.html こちらで教えていただいた以下のコードに、 J2のセルに連番を振るコードを付け足したいと思い、 同じくこちらのサイトの過去の履歴にあった以下コードを参考にとやってみているのですが、 Next で指定された変数の参照が無効です。と言われてしまいます… 印刷部数の指定はいらず、sheet印刷のJ2セルに1から始まる連番を振りたいのです。 どのように修正をしたらいいのかご教示願います。 Sub Sample4() Dim i As Long, endRow1 As Long, endRow2 As Long, myArea1 As Range, myArea2 As Range Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet Set wS1 = Worksheets("DB") Set wS2 = Worksheets("印刷") Set wS3 = Worksheets("Sheet3") endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True wS1.Range("A:A").Copy wS3.Range("A1") wS1.ShowAllData For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row If endRow2 > 9 Then Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "H")).ClearContents Range(wS2.Cells(10, "J"), wS2.Cells(endRow2, "J")).ClearContents End If wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A") wS2.Range("B6") = wS3.Cells(i, "A") Set myArea1 = Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "H")).SpecialCells(xlCellTypeVisible) Set myArea2 = Range(wS1.Cells(2, "I"), wS1.Cells(endRow1, "I")).SpecialCells(xlCellTypeVisible) myArea1.Copy wS2.Activate ActiveSheet.Range("B10").Select Selection.PasteSpecial Paste:=xlPasteValues myArea2.Copy wS2.Activate ActiveSheet.Range("J10").Select Selection.PasteSpecial Paste:=xlPasteValues endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row 'Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J")).PrintOut Next i wS1.AutoFilterMode = False wS3.Cells.Clear End Sub 連番印刷のコード Sub NumberPrint() Dim idx As Integer Dim res  res = Application.InputBox("印刷部数を入力してください", Type:=1)  If res > 0 Then   For idx = 1 To res    Range("AW3").Value = idx    ActiveSheet.PrintOut   Next idx  End If End Sub

  • VBA転記について教えて下さい

    200件位のデータがあるとします。顧客情報AB・商品C&#65374;AY 氏名 性  青森りんご 長野りんご みかん バナナ 送料 AA  男   1             2      100 BB  女          1            100 CC  男                   3     0 このデータを別シートAにはりんごと送料 別シートBにはそれ以外のデータに分けたいのです。 シートA 氏名 性  青森りんご 長野りんご  送料 AA  男   1           100 BB  女        1    100 CC  男 シートB 氏名 性  みかん バナナ AA  男    2 BB  女 CC  男       3 こんな感じです。 色々参考にして作成しましたがうまくいきませんでしたので 教えて欲しいです。 よろしくお願いします。 エクセルは2002です。 1、項目名の転記でデータは200位ですが変動があるので最終行で作成したら うまくいきませんでした。 2、データ域の転記が動きません。 Sub サンプル() Dim i As Long Dim lastRow As Long Dim lastcolumns As Long Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet Dim myColumns As Long Dim myKey As String Set S1 = Worksheets("データ") Set S2 = Worksheets("りんご") Set S3 = Worksheets("その他") ' Sheet1の最終行を取得 lastRow = S1.Range("A" & Rows.Count).End(xlUp).Row ' Sheet1の最終列を取得 lastcolumns = S1.Cells(1, Columns.Count).End(xlToLeft).Column ' 項目名の転記 S2.Range("A1:B200").Value = _ S1.Range("A1:B200").Value S3.Range("A1:B200").Value = _ S1.Range("A1:B200").Value 'データ域の転記 For i = 2 To lastcolumns myKey = S1.Cells(1 & i).Value If myKey <> "" Then myColumns = Worksheets(myKey).Cells(1, Columns.Count).End(xlUp).Columns + 1 S1.Range(S1.Cells(1, i), S1.Cells(lastRow, i)).Copy _ Worksheets(myKey).Range(Cells(1, myColumns), Cells(lastRow, myColumns)) End If Next i 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>

  • エクセルVBAマクロの質問です。

    マクロ初心者です。行き詰まってます。 sheet1には300件程度のデータがあります。 このデータの3列目の値を、VLOOKUPでsheet3のA1:B30範囲から参照します。そこで取得した回数分、sheet1の各行のデータをsheet2にコピーしたいんです。 そこで、コード文を作ってみましたが、マクロがうまく動きません。 すみませんが、お知恵を貸していただけないでしょうか? Dim Z as Long Dim L As Long Dim P As Long Dim Kensaku As String Dim M4 As Range Dim PRow As Long Dim i As Long Set M4 =Sheets(“sheet3”).Range(“A1:B30“) L = Sheets(“sheet1”).Range(“A1”).End(xlup).Row For Z = 1 to L-1 Kensaku = Sheets(“sheet1”).Cells(Z+1,3).Value P=Worksheetfunction.Vlookup(Kensaku,M4,2,False)    For i = 1 to P      Prow=Sheets(“sheet2”).Range("A1").End(xlDown).Row      Sheets(“sheet1”).Rows(Z+1).Copy Sheets(“sheet2”).Rows(Prow)    Nexti Next Z

  • 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