• ベストアンサー
※ ChatGPTを利用し、要約された質問です（原文：エクセル　マクロについてです）

エクセルマクロで複数人の回答を集計する方法

このQ&Aのポイント
  • エクセルマクロを使用して複数人の回答を集計する方法について教えてください。
  • 具体的には、シート2の特定のセルに一行だけ転記する方法や、シートを増やして回答を整理する方法が知りたいです。また、ボタンを押すと転記が行われる設定についても教えてください。
  • クラブ活動の合間に各々が回答してもらう予定ですので、効率的な方法を教えていただきたいです。
回答 全件
ベストアンサー
＞Sheet2（転記データの横）の　G　H　I　とかに　 D4　A５　…

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

  • ベストアンサー
  • hallo-2007
  • ベストアンサー率41% (888/2115)
回答No.1

＞Sheet2（転記データの横）の　G　H　I　とかに　 D4　A５　A6と3箇所 ですので ・・・ wst2.Range("A" & myRow) = wst1.Range("D4") wst2.Range("B" & myRow) = wst1.Range("A4") wst2.Range("G" & myRow) = wst1.Range("D4") wst2.Range("H" & myRow) = wst1.Range("A5") wst2.Range("I" & myRow) = wst1.Range("A6") wst2.Range("C" & myRow) = wst1.Range("A" & i) wst2.Range("D" & myRow) = wst1.Range("B" & i) ・・・ と追加します。 wst1.Range("A4").ClearContents も必要なら同様に追加します。

maki_riko
質問者

お礼

確認しました！素晴らしいでーす！！！思った通りに出来ました、スッキリしました。 しかもこんなにお早くありがとうございました。 早速色々と仕上げに掛かろうと思います。大変感謝致しますm(_ _)m またよろしくお願い致します

全文を見る
すると、全ての回答が全文表示されます。
  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. Excel（エクセル）

関連するQ&A

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

    エクセル2013VBAで最終行を取得しての転記が上手くいきません。どのようにすれば良いかご教授ください。 簡単なサンプルを下記します。 Sub サンプル入力からのDBへの転記() Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim myRow As Long Set Sh1 = Worksheets("サンプル入力") Set Sh2 = Worksheets("サンプルDB") With Sh2 myRow = Range("A" & Rows.Count).End(xlUp).Row + 1 .Range("A" & myRow).Value = Sh1.Range("D4").Value .Range("B" & myRow).Value = Sh1.Range("F4").Value End With End Sub 入力内容を変えないテストでは (1)実行するとDBへの転記は問題なく出来ます。 (2)継続してマクロを実行しても問題なく転記が行われ、同じデータが蓄積されていきます。 入力内容を変更して引き続きマクロを実行すると挙動不審に陥ります。 現象としては (1)初めの行に何度も重ねて転記を行う。 (2)空白行を作り、その行に何度も転記を行ってしまう。 (3)空白行を作り、それ以降転記を実行し蓄積を行ってしまう。 入力シートには結合セル、リストを使用していますが、原因究明を行う中でこれが原因とは思えませんでした。 これがクリアできないと先に進めません。ぜひお力を貸してください。 宜しくお願い申し上げます。

  • オートフィルタをマクロで書いたのですが、一部うまくいかなくて困っていま

    オートフィルタをマクロで書いたのですが、一部うまくいかなくて困っています。 わかる方がいらしたらぜひご教授ください。 商品情報というブックがあり、抽出シート(１枚目）と２枚目のシートにデータが入っています。 ２枚目のシートのフィールド名を抽出シートのA1を基準に貼り付けています。 条件をA1：I2に入力し、２枚目のシートの条件に合うものを抽出シートのA5以降に取り出すマクロを書いています。次回マクロを起動させたときにA5以降にデータがあれば削除させます。 そこで問題なのですが、A1：I2の条件だとA列からI列までのフィールド名に対する条件を 1行入力することができますが、同じ行になるのでAND条件になってしまいます。 本当は条件列をI3までにして、条件を2行にわたって書いて　または条件も検索したいのです。 ただ、または条件は入力する場合と入力がない場合があります。 条件をA1:I3（3行目)に変更してマクロを実行すると、または 条件がある場合はちゃんとでるのですが、条件がない場合はすべてでてきてしまいます。 どのようにすればA1:I3に変更して、2行目と3行目に条件があった場合はその条件で該当するものを 抽出し、特に3行目に条件がない場合は2行目だけの条件で抽出できるのでしょうか？ （2行目のAnd条件検索と3行目のまたは条件検索ができますでしょうか？） Dim myRow1 As Long, myRow2 As Long myRow1 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row myRow2 = Sheets("抽出").Range("A" & Rows.Count).End(xlUp).Row If myRow2 >= 5 Then Sheets("抽出").Range("A5:I" & myRow2).ClearContents Sheets("抽出").Range("A5:I" & myRow2).ClearFormats End If Sheets(2).Range("A1:I" & myRow1).AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Worksheets("抽出").Range("A1:I2"), CopyToRange:=Sheets("抽出").Range("A5"), Unique:=False End Sub

  • 複数行を最終行に転記

    ブックから他ブックへの複数行を最終行に転記したいと考えております。 1日1行であれば転記出来るものの、1日が複数行となると1日の最終行のみが転記され困っております。 縦カレンダー仕様 ・月初ではなく日曜始まりの為前月含むこともあり ・1日につき各4行づつ ・4行すべて毎日データーが入るわけではなく時々入る程度 スケジュール表仕様 ・日曜始まりの一週間毎のシート ・1日につき9行分 1か月分だと長いので1週目分だけですが… Activ bookを縦カレンダー(入力用シート) Thisbookをスケジュール表(転記先シート） Sub 転記_Click() Dim WBK1 As Workbook,WBK2 As Workbook Dim SH1 As Worksheet,SH2 As Worksheet Dim myRow1 As Long,myRow2 As Long,myRow3 As Long,myRow4 As Long_ myRow5 As Long,myRow6 As Long,myRow7 As Long Set WBK1 = ThisWorkbook '縦カレンダー Set WBK2 = ActiveWorkbook 'スケジュール表 Set SH1 = WBK1.Worksheets("1週目") 'スケジュール表 Set SH2 = WBK2.Worksheets("3月") '縦カレンダー Set SH3 = WBK1.Worksheets("2週目") 'スケジュール表 Set SH4 = WBK1.Worksheets("3週目") 'スケジュール表 Set SH5 = WBK1.Worksheets("4週目") 'スケジュール表 Set SH6 = WBK1.Worksheets("5週目") 'スケジュール表 Set SH7 = WBK1.Worksheets("6週目") 'スケジュール表 With SH1 myRow1 = SH1.Range("C1").End(xlDown).Row '日 myRow2 = SH1.Range("C12").End(xlDown).Row '月 myRow3 = SH1.Range("C23").End(xlDown).Row '火 myRow4 = SH1.Range("C34").End(xlDown).Row '水 myRow5 = SH1.Range("C45").End(xlDown).Row '木 myRow6 = SH1.Range("C56").End(xlDown).Row '金 myRow7 = SH1.Range("C67").End(xlDown).Row '土 SH1.Range("C" & myRow1 + 1 & ":J" & myRow1 + 1).Value = SH2.Range("C3:J6").Value '日 SH1.Range("C" & myRow2 + 1 & ":J" & myRow2 + 1).Value = SH2.Range("C7:J10").Value '月 SH1.Range("C" & myRow3 + 1 & ":J" & myRow3 + 1).Value = SH2.Range("C11:J14").Value '火 SH1.Range("C" & myRow4 + 1 & ":J" & myRow4 + 1).Value = SH2.Range("C15:J18").Value '水 SH1.Range("C" & myRow5 + 1 & ":J" & myRow5 + 1).Value = SH2.Range("C19:J22").Value '木 SH1.Range("C" & myRow6 + 1 & ":J" & myRow6 + 1).Value = SH2.Range("C23:J26").Value '金 SH1.Range("C" & myRow7 + 1 & ":J" & myRow7 + 1).Value = SH2.Range("C27:J30").Value '土 　 End With End Sub

  • エクセルのマクロで検索・抽出したデータを修正及び更新して元データに反映

    エクセルのマクロで検索・抽出したデータを修正及び更新して元データに反映させたい。 Sheet1に元データが行単位で入力されています。。 　　A　　　B　　　　C　　　　D　　　　E F 1　日付 顧客名 契約料 担当 回収日 回収金額 2 3 | 50 Sheet2で複数条件でフィルタオプションをマクロで実行し結果を表示ています。 　　A　　　　B　　　　C　　　D　　　　E 1　日付～　日付マデ　顧客名　担当者 2　1/1　　 2/28 　　　　高橋　　　　　　--------->検索条件 3 4　日付 顧客名 担当 回収日 回収金額 5　-------------------------------------->抽出結果 6　-------------------------------------->抽出結果 7　-------------------------------------->抽出結果 マクロは下記の通りです。 Public Sub 検索() Dim myRow1 As Long, myRow2 As Long '----Sheet1とSheet2のA列で最終行を捜します。 myRow1 = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row myRow2 = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row '----Sheet2のA5以下が入力されていたらクリアします。 If myRow2 >= 5 Then Sheets("Sheet2").Range("A5:P" & myRow2).ClearContents End If '----フィルタオプションの設定で抽出します。 '----元データはSheet1、抽出条件はSheet2のA1:D2、抽出先はSheet2のA4:E4です。 Sheets("Sheet1").Range("A1:F" & myRow1).AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=Sheets("Sheet2").Range("A1:D2"), _ CopyToRange:=Sheets("Sheet2").Range("A4:E4"), _ Unique:=False End Sub 抽出結果の各セルデータを必要に応じて変更・修正（選出結果を直に）をしそれを元データ に反映（上書き？）させるようなマクロを作成したいです。 どなたかご指導よろしくお願いいたします。 うまく説明できないので画像を添付します。

  • エクセル　マクロ　繰り返し処理の制御方法について

    お世話になります。エクセル初心者です。 登録用のシートから（データ数は、5000行ほど）、印刷用のシートへの転記を考えています。 　下記のコードはテスト用の簡易なものですが、試行錯誤でここまではたどりついたのですが。 　A列には大分類用の番号を入れてあるので、A列のセルの値が変わるまで、同じ処理を繰り返したいのですが、そのためにはどうしたらよいでしょうか。下記のコードの i と j の変数部分を連動させたい（A列の同じ値の数だけ、５行おきの転記をしたい）のですが。 　Do until 構文も試してみたのですが（下記のコードでは、テストなので、「=2」のように固定にして（a)の部分に挿入してみました。）、エラーメッセージに従い、Loop の位置を(b)から(c)に変えてみたところ、無限ループに陥り、対処に困っています。 　よろしくお願いします。 Sub test3() Dim i As Long Dim j As Long i = 1 '転記元の行 'Do until range("A"&i)=2 -----------------------(a) For j = 1 To 200 Step 5 '転記先の行 Range("J" & j) = Range("B" & i) Range("k" & j) = Range("C" & i) Range("L" & j) = Range("D" & i) Range("J" & j + 1) = Range("E" & i) Range("J" & j + 2) = Range("F" & i) Range("J" & j + 3) = Range("G" & i) i = i + 1 'Loop-------------------------------------------'(b) Next j 'Loop-------------------------------------------'(c) End Sub

  • エクセル2003マクロの機能追加

    Sub test() Dim 行1 As Long, 最終行 As Long, 行2 As Long Sheets("Sheet2").Cells.ClearContents Sheets("Sheet1").Activate 最終行 = Range("C65536").End(xlUp).Row 行2 = 1 For 行1 = 1 To 最終行 Sheets("Sheet2").Cells(行2, 1).Resize(1, 3) = Range(Cells(行1, 1), Cells(行1, 3)).Value If Range("A" & 行1).Font.Bold Then Sheets("Sheet2").Range("A" & 行2) = Range("A" & 行1) & "-1" Sheets("Sheet2").Cells(行2 + 1, 1).Resize(1, 3) = Range(Cells(行1, 1), Cells(行1, 3)).Value Sheets("Sheet2").Range("A" & 行2 + 1) = Range("A" & 行1) & "-2" 行2 = 行2 + 1 End If If Range("A" & 行1) = "" Then 行2 = 行2 - 1 Sheets("Sheet2").Range("C" & 行2) = Sheets("Sheet2").Range("C" & 行2) + Range("C" & 行1) End If 行2 = 行2 + 1 Next 行1 End Sub 元データ AAAA5　9601　　950 BBBB1　9660　　150 ASAS9　9654　　-50 AXCW5　9603　　1375 以下の用にマクロで変換する機能を追加したいのです AAAA5　9601　　950 BBBB1-1　9660　　150 BBBB1-2　9660　　150 ASAS9　9654　　50 AXCW5　9603　　1375 宜しくおねがいします。

  • エクセル2003マクロの再編集

    Sub test() Dim 行1 As Long, 最終行 As Long, 行2 As Long Sheets("Sheet2").Cells.ClearContents Sheets("Sheet1").Activate 最終行 = Range("C65536").End(xlUp).Row 行2 = 1 For 行1 = 1 To 最終行 Sheets("Sheet2").Cells(行2, 1).Resize(1, 3) = Range(Cells(行1, 1), Cells(行1, 3)).Value Sheets("Sheet2").Cells(行2, 3).Value = Abs(Sheets("Sheet2").Cells(行2, 3).Value) If Range("A" & 行1).Value = "BBBB1" Then Sheets("Sheet2").Range("A" & 行2) = Range("A" & 行1) & "-1" Sheets("Sheet2").Cells(行2 + 1, 1).Resize(1, 3) = Range(Cells(行1, 1), Cells(行1, 3)).Value Sheets("Sheet2").Range("A" & 行2 + 1) = Range("A" & 行1) & "-2" 行2 = 行2 + 1 End If If Range("A" & 行1) = "" Then 行2 = 行2 - 1 Sheets("Sheet2").Range("C" & 行2) = Sheets("Sheet2").Range("C" & 行2) + Range("C" & 行1) End If 行2 = 行2 + 1 Next 行1 End Sub を編集したいのですが全然図りません ご指導お願いします 元データ AAAA5　9601　　950 BBBB1　9660　　150 ASAS9　9654　　-50 AXCW5　9603　　1375 以下の用にマクロで変換する用に出来たのですが 【1】 BBBB1だけではなくAAAA5も対処になったときの 追加方法です 元データは一切変更が出来ません ※フォントの変更も不可です 【2】 元データと変換後データがSheet1からSheet2になっていますが Sheet1の元は範囲はA1～C400で変換後をSheet1E1～G400にしたいのです AAAA5　9601　　950　 BBBB1-1　9660　　150　 BBBB1-2　9660　　150 ASAS9　9654　　50 AXCW5　9603　　1375

  • EXCEL VBAの配列でわかりません。

    こんなコードがあるのですが、最後の他のシート（作業中シート）に書き込もうとするとエラーになってしまいます。”Sheets("作業中").”を抜くと同じシートに結果は返ってくるのですが…。コードの内容は、ある範囲のある列から空白ではないセルを探し出してその行のデータを配列で汲み取り、他のシートに一括で洗い出すというものです。 Sub 作業中() Dim myRow As Long Dim Data As Variant Dim WC() As Variant Dim WCE() As Variant myRow = Range("H1").CurrentRegion.Rows.Count Data = Range("H1:M" & myRow).Value For i = 1 To myRow If Data(i, 5) <> "" Then a = a + 1 Else b = b + 1 End If Next ReDim WC(a) ReDim WCE(b) c = 0 d = 0 For i = 1 To myRow If Data(i, 5) <> "" Then WC(c) = Range("H" & i & ":K" & i).Value c = c + 1 Else WCE(d) = Range(Cells(i, 8), Cells(i, 11)).Value d = d + 1 End If Next For i = 0 To a Range(Cells(i + 1, 15), Cells(i + 1, 18)).Value = WC(i) Next For i = 0 To b Range(Cells(i + 1, 19), Cells(i + 1, 22)).Value = WCE(i) Next e = Range(Cells(1, 15), Cells(a, 18)).Value Sheets("作業中").Range(Cells(1, 1), Cells(a, 4)).Value = e End Sub ちなみに同じシートから↓のコードを実行するとうまくいきます。 なぜ～？？わからな～い？？おしえてくださーい！！ Sub test() Dim a As Variant a = Range("H1:K4") Sheets("作業中").Range("N1:Q4") = a End Sub

  • VBA マクロ　シート　転記

    はじめまして。VBA初心者です。今シート１のA列1行目セルにA社、A列2行目にB社、A列3行目にC社と・・ざっと1000行程あり、それぞれB列には値があります。この値をシート２のＢ列に転記したいと思っています。ただ、毎月シートを追加していきますので、左隣のシートから転記しなければなりません。シート２の項目は同じA列とB列で構成されています。A列の値が多少前後するので、FINDを使って以下のようなプログラムを作りました。ただ、左隣のシートから転記とう内容をどうやって追加したら良いのかがわかりません。Previous　をどこかに使えばできるのかなとも思うのですが、その方法がわかりません。 Sub 転記() Dim ws As Worksheet, ws1 As Worksheet, r As Range, r1 As Range Dim LastRow As Long, i As Long, er As Long, wkey As String Set ws = Worksheets("Sheet1") Set ws1 = Worksheets("Sheet2") LastRow = ws.Range("A1").End(xlDown).Row er = ws1.Range("A1").End(xlDown).Row Set r = ws.Range("A1:A" & LastRow) For i = 1 To er wkey = ws1.Range("A" & i) Set r1 = r.Find(What:=wkey, LookIn:=xlValues, LookAt:=xlWhole) If Not r1 Is Nothing Then ws1.Range("B" & i) = r1.Offset(, 1) End If Next Set r1 = Nothing Set r = Nothing Set ws = Nothing Set ws1 = Nothing End Sub どなたか詳しいお方いらっしゃいましたら、初心者の私に教えて頂けませんでしょうか？宜しくお願いします。

  • Excel２０００マクロ記述の変更について

    下記のマクロを記述しています。 条件が変わったので変更したいのですが、変更の記述の仕方を 教えてください。 現在の条件 If (.Range("D" & i) = "A310" Or .Range("D" & i) = "A505") And .Range("V" & i) <= 1000 変更の条件 倉庫マスタ（シート名）のＢ列の５行目以降とＡＣＴ（シート名）のＤ列の６行目以降を参照して同じデータで、倉庫マスタのＧ列の５行目に記号が入っている場合は、ＡＣＴ（シート名）の６行目からに 下記の条件を設定したい。 .Cells(i, "M").ClearContents .Cells(i, "O").Resize(1, 15).ClearContents Sub 再表示1() Dim SheetName As String Dim i As Integer Dim LastRow As Integer Dim rng As Range SheetName = "ＡＣＴ" 'シート名 LastRow = 3000 '最終行の番号 With Sheets(SheetName) Sheets("ＡＣＴ").Select For i = 6 To LastRow If (.Range("D" & i) = "A310" Or .Range("D" & i) = "A505") And .Range("V" & i) <= 1000 Then .Cells(i, "M").ClearContents '原料平均データ消去 .Cells(i, "O").Resize(1, 15).ClearContents '前月末在庫～発注後在庫欄までデータを消去 End If Next End With End Sub

LENOVO ダウンロードサイトでS/N無効
このQ&Aのポイント
  • Lenovo G50-70 2台のHDD交換を検討しているが、ダウンロードサイトでUSBリカバリーディスクを作成しようとすると、入力したシリアルナンバーが無効とされる。
  • 2台のLenovo G50-70でダウンロードサイトでのリカバリーディスク作成を試みるが、入力したシリアルナンバーが見つからず、作成できない。
  • Lenovo G50-70のダウンロードサイトでUSBリカバリーディスクを作成しようとするが、シリアルナンバーが無効として認識されず、作成ができない。なぜでしょうか？
回答を見る

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する