• ベストアンサー
  • すぐに回答を!

エクセル2003 別シートの項目を集計したいVBA

仕事でエクセル2003を使っています。 超初心者なので、うまく説明ができませんがお許しください。 Sheet1に、印刷シートとして「名前」「フリガナ」「住所」「電話番号」「性別」などのデータを入力しています。 これを1回ずつデータを入力して印刷をしています。 印刷をするときに、入力したデータをリストにするためにSheet2へコピーするというマクロを作りました。 ↓こんな風に作ってみました。 Sub 正方形長方形2_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("Sheet3") x = ws2.Cells(Rows.Count, "b").End(xlUp).Row + 1 y = ws1.Cells(Rows.Count, "b").End(xlUp).Row ws1.Cells(21, "g").Resize(y, 9).Copy ws2.Cells(x, "b").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False End Sub Sub macro02() Worksheets("Sheet1").PrintOut End Sub ここから本題なのですが… ふと、リストの件数をSheet1に出せないものか?と思ったのです。 マクロを実行することで、Sheet2にデータが増えてその増えたデータの項目の合計件数をSheet1に反映させて印刷する。 「別シートの項目を集計する」で検索してみたのですが、私には難しすぎて理解できずいろんな方の回答をもアレンジできません。 なにとぞ、ご教授いただきますようお願いします。

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

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

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

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

現状の説明がされていないので勝手に下記のような条件だと仮定して記載します。 シート1に1行1案件で何件か入力し後、macro01()でシート3のリスト表にデータを追加で値のみのペーストを実施するマクロは思い通り実行できているので修正の必要が無い。 案件数をシート1に記載したい。 シート3にコピーした後に再度シート3の最終行を取得すれば案件数を取得出来ますよね。 仮にシート3のリスト作成がB3から開始している場合は最終行番号-2が案件数となります。 案件数をセルA1に入力するとした.。 作成表に見合った修正を行って下さい。 ws2.Cells(x, "b").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False ws1.Range("A1").value = ws2.Cells(Rows.Count, "b").End(xlUp).Row -2 End Sub 質問の趣旨と違っていてもご容赦を

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

質問者からのお礼

ありがとうございます(#^.^#) 「ws1.Range("A1").value = ws2.Cells(Rows.Count, "b").End(xlUp).Row -2」   ↑これだけでできちゃうんですねぇ あーでもない、こーでもないと悩んでたので、「ひぃ~(@_@;)」でした。 明日、会社に行くのが楽しみです。 本当にありがとうございました。

関連するQ&A

  • 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行空いてしまうのです。 上記にマクロは家で作って会社ではそのマクロを入力する形です。 マクロの意味が全く分からず、どこを修正すればいいのかもわかりません。 お力をお貸しください。 よろしくお願いいたします。

  • エクセルで入力シートから別シートに転記・蓄積について

    エクセルVBAで入力シートのA1:D5(5行)の範囲を別シート(DBシート)の転記・蓄積させる方法を教えてください。また、入力データがA1:A5(1行)のときもあれば、A1:D5(5行)の場合ですが・・・ Sub test01() Dim ws1 As Worksheet, ws2 As Worksheet Dim x As Long, y As Long Set ws1 = Sheets("入力") Set ws2 = Sheets("DB") x = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1 y = ws1.Cells(Rows.Count, "A").End(xlUp).Row ws1.Cells(1, "A").Resize(y, 4).Copy ws2.Cells(x, "A") End Sub の場合、数式等、入力値すべてが転記となってしまいます。 値だけ転記する方法はありませんか? 宜しくお願いいたします。

  • マクロを使って・・・

    シート1に入力したデータをシート2にコピーするいうマクロを作りました。 シート2にコピーはできるのですが 例えば、そのデータを消して再度新しいデータを入れていきたいと思い エクセル左上のシート全体を選択して「Delete」を押すと 会社のエクセル(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

その他の回答 (1)

  • 回答No.2
  • kmetu
  • ベストアンサー率41% (562/1346)

マクロでなくても文字の入ったセルの件数でしたらCOUNTA関数を使えば表示できますよ。 =COUNTA(Sheet2!B:B) 列の数え始めたい行が一行目からではないのでしたら =COUNTA(Sheet2!B3:B1000) とか指定してください。

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

質問者からのお礼

ありがとうございます。 やり方が悪かったのか…質問を出す前にはうまく同期(と、いう表現でいいのでしょうか?)ができずに「「やはり、マクロなのか?」と思っていました。 試してみましたところ、できました。 いろんな方法があるんですねぇ。 本当にありがとうございました。

関連するQ&A

  • VBAでワークシートを変数にするとき

    たとえばSheet1とSheet2を一度に選択する場合、 Sub Macro6() Sheets(Array("Sheet1", "Sheet2")).Select End Sub と書くと思います。 ワークシートを変数で書く場合は Sub test() Dim ws1 As Worksheet, ws2 As Worksheet Sheets(Array(ws1.Name, ws2.Name)).Select End Sub と、いちいち名前で指定しなければならないのでしょうか? それとももっと別の書き方があるのでしょうか?

  • 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

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

  • 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

  • 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でデーターを一括取得するつもりなのですが この段階でうまくいきません。

  • Excelの1シートを項目別に別シートへ分割

    左図のようなシートがあります。C列(部署番号)の左3桁をキーにデータとシートを分け、右図のようにシート名もその左3桁の名前にしたいと考えています。(部署番号)をキーにする場合は以下の通りとなると思うのですが Sub test1() Dim n As String Dim c, L As Long Dim ws1 As Worksheet On Error GoTo ErrorHandler Set ws1 = Sheets("Sheet1") L = ws1.Range("C65536").End(xlUp).Row For i = 2 To L n = ws1.Range("C" & i) '部門名抽出 c = Sheets(n).Range("C65536").End(xlUp).Row '部門のシートの最終行位置 ws1.Rows(i).Copy Destination:=Sheets(n).Rows(c + 1) Next i Exit Sub ErrorHandler: '部門のシートが無い時の処理 Worksheets.Add.Move after:=Worksheets(Worksheets.Count) '最後のシートの後へ追加 Worksheets(Worksheets.Count).Name = n '部門の名前をシートの名前にする ws1.Rows(1).Copy Destination:=Sheets(n).Rows(1) '1行目の項目名をコピー Resume End Sub (部署番号)の左3桁をキーにした時のコーディングがどうしても分かりません。このようなことが出来ますでしょうか。因みに元データとなる"sheet1"はそのまま残します。どうかご教授の程宜しくお願い致します。

  • 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

  • 置換のマクロ

    すみません、基礎的なことかもしれませんが、 調べてもわかりませんでした… 下記マクロで、今はwS1のA列に置換したい文字があった場合 置換をしてくれますが、 A列だけではなく、wS1のシート全体を指定する為にはどのように書き換えればいいでしょうか…? Replace(wS1.Cells(i, "A"), wS2.Cells(k, "A") の wS1.Cells(i, "A") を Aではなく、シート全体の指定に変えたいのです。。 Sub 置換() Dim i As Long, k As Long, wS1 As Worksheet, wS2 As Worksheet Set wS1 = ActiveSheet Set wS2 = Worksheets("置換") Application.ScreenUpdating = False For i = 1 To wS1.Cells(Rows.Count, "A").End(xlUp).Row For k = 1 To wS2.Cells(Rows.Count, "A").End(xlUp).Row If InStr(wS1.Cells(i, "A"), wS2.Cells(k, "A")) > 0 Then wS1.Cells(i, "A") = Replace(wS1.Cells(i, "A"), wS2.Cells(k, "A"), wS2.Cells(k, "B")) End If Next k Next i Application.ScreenUpdating = True End Sub 過去の質問↓の回答にあったマクロから、少し変えて使わせていただいています。 http://okwave.jp/qa/q8293972.html

  • 2枚のエクセルのシートを図のように統合させる

    2枚のエクセルのシートを統合させるやり方を教えて下さい。 (同じ項目に2人の人が答えている場合2行に分けることはできますか。) 以前こちらで質問させていただいたとき、 Sub test() Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim Sh3 As Worksheet Set Sh1 = Workbooks("book1.xls").Sheets("Sheet1") Set Sh2 = Workbooks("book2.xls").Sheets("Sheet1") Set Sh3 = Workbooks("book3.xls").Sheets("Sheet1") Sh1.Range("B5").CurrentRegion.Copy Sh3.Range("B5") With Sh2.Range("B5").CurrentRegion .Resize(.Rows.Count - 1).Offset(1).Copy Sh3.Cells(Sh3.Rows.Count, "B").End(xlUp).Offset(1) End With With Sh3 Dim r As Long For r = .Cells(.Rows.Count, "B").End(xlUp).Row To 6 Step -1 If .Cells(r, "C").Value = "" Then .Rows(r).Delete Next r .Range("B5").CurrentRegion.Sort Key1:=.Range("B6"), Order1:=xlAscending, Header:=xlYes For r = .Cells(.Rows.Count, "B").End(xlUp).Row To 6 Step -1 If .Cells(r, "B").Value = .Cells(r - 1, "B").Value Then .Cells(r, "B").ClearContents Next r End With End Sub というコードを教えていただいたのですが、項目の中があいうえお順になってしまいうまくいきません。 そして、途中に項目があったりしてこれは1つだけ表示されるようにできますか? 説明が足りないところは、補足いたします。 いきなり部署を異動させられて今までやったことないようなことをやっています(涙) どなたか教えて下さいよろしくお願いします。

  • Excel 2007 マクロのIF構文について

    Excel 2007 マクロのIF構文について Sheet1からSheet2にIF構文を使用して、 必要な情報を転記するマクロです。 下記マクロで実現できているのですが、IF構文が多く もっと効率的なマクロがあるのではないかと考えています。 IF構文が2つありますが、1つにまとめるマクロがありましたら お教えください。 Sub Rist() Dim i, j As Long Dim ws1, ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '「Sheet1」シートを更新 Worksheets("Sheet1").Range("A1").ListObject.QueryTable.Refresh BackgroundQuery:=False '「Sheet1」シートから「Sheet2」シートに転記 For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row For j = 2 To ws2.Cells(Rows.Count, 13).End(xlUp).Row '「Sheet1」シートのL列から「Sheet2」シートのS列に転記 If ws2.Cells(j, "M") = ws1.Cells(i, "A") Then ws2.Cells(j, "S") = ws1.Cells(i, "L") End If '「Sheet1」シートのG列から「Sheet2」シートのQ列に転記 If ws2.Cells(j, "M") = ws1.Cells(i, "A") Then ws2.Cells(j, "Q") = ws1.Cells(i, "G") End If Next j Next i End Sub