Excel2007 マクロ 複数シートの作成

このQ&Aのポイント
  • Excel2007のマクロを使用して、複数のシートを作成する方法について教えてください。
  • 作成したマクロの中で、Dataシートの情報を新しいシートに反映させたいのですが、うまくいきません。
  • 修正箇所が分からないため、アドバイスをお願いします。
回答を見る
  • ベストアンサー

Excel2007 マクロ 複数シートの作成

Excel2007 マクロ 複数シートの作成 1つのファイルにtempシートとDataシートがあります。 DataシートのNo順にシートをコピーしていきます。 シートのコピーはうまくいきました。 Dataシートの情報(会社名、担当者名)を反映したいのですが うまく反映しません。 自分が作成したマクロを下記に記載いたします。 Sub CreateSheet() Dim lnFm As Long Dim lnFmMx As Long Dim st As String Dim shFm As Worksheet Dim shTo As Worksheet Set shFm = Worksheets("Data") lnFmMx = shFm.Range("B65536").End(xlUp).Row Dim Into As Long For lnFm = 2 To lnFmMx If st <> shFm.Range("B" & lnFm).Value Then st = shFm.Range("B" & lnFm).Value Sheets("temp").Copy After:=Sheets(2) Set shTo = ActiveSheet shTo.Name = st Into = 1 End If shTo.Range("B1" & Into).Value = shFm.Range("B2" & lnFm).Value shTo.Range("B2" & Into).Value = shFm.Range("C2" & lnFm).Value Next shFm.Activate End Sub 下記2行が違うと思うのですが、修正箇所が分かりません。 shTo.Range("B1" & Into).Value = shFm.Range("B2" & lnFm).Value shTo.Range("B2" & Into).Value = shFm.Range("C2" & lnFm).Value また実際のNo数は50ぐらいあります。 アドバイス頂けますでしょうか。

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

  • ベストアンサー
  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.4

>下記2行が違うと思うのですが、修正箇所が分かりません。 >shTo.Range("B1" & Into).Value = shFm.Range("B2" & lnFm).Value >shTo.Range("B2" & Into).Value = shFm.Range("C2" & lnFm).Value shTo.Range("B1").Value = shFm.Range("B" & lnFm).Value shTo.Range("B2").Value = shFm.Range("C" & lnFm).Value ということでしょうね。あまり、凝った書き方をしないで、カウンター変数は、一文字(i,j,k,m,n,x,y,a,b)などが良いと思います。 私の書き方です。少し、参考にしてみてください。 shTmp.Cells.Copy .Cells(1, 1) こういう方法にするのは、シートオブジェクトそのものをコピーすると、別の見えないものまでコピーする可能性がありますので、私などは、使いません。 また、Range の中の引数は、基本的には文字列なのですが、引数の中で、データ型が変換されることを嫌って、私は、Cells にさせます。 '// Sub TestMacro1()  Dim shFm As Worksheet  Dim shTmp As Worksheet  Dim i As Long    Set shFm = Worksheets("Data")  Set shTmp = Worksheets("Temp")  'For i = shFm.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 '順序をあわせる  For i = 2 To shFm.Cells(Rows.Count, 1).End(xlUp).Row   If shFm.Cells(i, 2).Value <> "" Then    With Worksheets.Add(After:=Worksheets(2))     shTmp.Cells.Copy .Cells(1, 1)     .Cells(1, 2).Value = shFm.Cells(i, 2).Value     .Cells(2, 2).Value = shFm.Cells(i, 3).Value     .Name = shFm.Cells(i, 2).Value    End With   End If  Next  shFm.Select  Set shFm = Nothing  Set shTmp = Nothing End Sub

hyogara777
質問者

お礼

ご回答ありがとうございました。またシンプルなソースを頂き非常に助かります。

その他の回答 (3)

  • myRange
  • ベストアンサー率71% (339/472)
回答No.3

回答2、myRangeです。 もしかして、 、 >shTo.Range("B1" & Into).Value = shFm.Range("B2" & lnFm).Value >shTo.Range("▼B▼2" & Into).Value = shFm.Range("C2" & lnFm).Value この2行目の左辺に"B2" & Into とIntoが使われているということは B列ではなくて、右辺と同じくC列としたい? タイプミス? であれば、 shTo.Range("B" & Into).Value = shFm.Range("B" & lnFm).Value shTo.Range("C" & Into).Value = shFm.Range("C" & lnFm).Value 以上です。

hyogara777
質問者

お礼

ご回答ありがとうございました。ご回答いただきました内容を実現したかったです。

  • myRange
  • ベストアンサー率71% (339/472)
回答No.2

>shTo.Range("B1" & Into).Value = shFm.Range("B2" & lnFm).Value >shTo.Range("B2" & Into).Value = shFm.Range("C2" & lnFm).Value たぶん、 shTo.Range("B1").Value = shFm.Range("B" & lnFm).Value shTo.Range("B2").Value = shFm.Range("C" & lnFm).Value ではないかと。 以上です。  

hyogara777
質問者

お礼

ご回答ありがとうございました。まずは試していかなければいけないということが分りました。

  • bin-chan
  • ベストアンサー率33% (1403/4213)
回答No.1

> shTo.Range("B1" & Into).Value = shFm.Range("B2" & lnFm).Value > shTo.Range("B2" & Into).Value = shFm.Range("C2" & lnFm).Value "B1" & Intoに期待する値は何? "B11"? 同様に "B2" & lnFmに期待する値は何? "B2" & Intoに期待する値は何? "C2" & lnFmに期待する値は何?

hyogara777
質問者

お礼

ご回答ありがとうございました。InFm、Intoの使い方を理解していませんでした。

関連するQ&A

  • エクセル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

  • EXCEL2000で作成したマクロが2007で動作しない

    EXCEL2000で作成したマクロがEXCEL2007上で動作しません。 2つのシートに入ったデータを,「抽出」シートにコピー後, 抽出条件に合わせて抽出するというものなのですが, 「Sheet1」で最終行を取得するところで,正しい範囲を 選択しません。どこが間違えているのか,ご指南頂けないでしょうか? お願いいたします。 下には,正しい結果が出ない所までを貼りつけました。 Sub フィルタオプション() Dim LastRow As Long, LastColumn As Long Dim myData As Range Dim myCriteria As Range Sheets("Sheet1").Select Rows("1:1").Select Selection.Copy Sheets("抽出").Select Rows("3:3").Select ActiveSheet.Paste If Worksheets("Sheet1").FilterMode = True Then   Worksheets("Sheet1").ShowAllData End If With Worksheets("Sheet1") LastRow = .Cells(Application.Rows.Count, "A").End(xlUp).Row End With Sheets("Sheet1").Select Range(Rows(2), Rows(LastRow)).Select Selection.Copy Range("A1").Select Sheets("抽出").Select Range(Rows(4), Rows(4)).Select Selection.Insert Shift:=xlDown

  • 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へ反映されません どなたか教えて頂けないでしょうか。

  • 特定の文字以外を入力すると別シートに表記する方法

    Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim StrRow As Long Dim TgtCol As Long Dim MaxRow As Long Dim ChgRow As Long Dim PutSh1 As Worksheet Dim PutSh2 As Worksheet Dim PutSh3 As Worksheet Dim PutCol As Long Dim PutRow As Long Dim ChgRng1 As Range Dim ChgRng2 As Range Dim ChgRng3 As Range StrRow = 5 MaxRow = 35 If Target.Count > 1 Then Exit Sub If Target.Value = "" Then Exit Sub Set PutSh1 = ThisWorkbook.Sheets("Sheet2") Set PutSh2 = ThisWorkbook.Sheets("Sheet3") Set PutSh3 = ThisWorkbook.Sheets("Sheet4") With ThisWorkbook.Sheets("Sheet1") Set ChgRng1 = Range(.Cells(StrRow, 3), .Cells(MaxRow, 3)) 'C列 Set ChgRng2 = Range(.Cells(StrRow, 5), .Cells(MaxRow, 5)) 'E列 Set ChgRng3 = Range(.Cells(StrRow, 7), .Cells(MaxRow, 7)) 'G列 End With ChgRow = Target.Row If Not Intersect(Target, ChgRng1) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh1, ChgRow, Target.Value End If If Not Intersect(Target, ChgRng2) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh2, ChgRow, Target.Value End If If Not Intersect(Target, ChgRng3) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh3, ChgRow, Target.Value End If End Sub 以前質問させて頂いた内容で追加の質問です。 Sheet1の指定したセルに「ー(ハイフン)」の文字がある時は、Sheet2〜4に転送(表記)しない方法を追加する場合はどの様にすれば宜しいでしょうか?

  • エクセル VBA シートの選択 

    windows XP でエクセル2000を使っています。 Sub aaa() Sheets("Sheet1").Select Dim a As String a = Cells(2, 4) Sheets(a).Select Range("A1").Select End Sub というマクロだと セルに入っている値のシート名を探してくれます。 ですが Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Intersect(Target, Range("B11:b683")) Is Nothing Then Exit Sub Worksheets("Sheet1").Range("C2").Value = Target.Value Dim b As String b = Range("C2).value (←ここをcellsにしてもダメ) Sheets(b).Select Range("A1").Select End Sub これだとsheets(b)を選びません。Sheets(b).Selectのところが黄色くなります。 何処が間違えているのでしょうか。 全くの素人ですが、仕事で必要に迫られています。 わかりやすく回答・解説くれると助かります。

  • 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

  • 印刷シートを分けたい

    excel2010を使用しています、今勉強中の初心者です、 dataシートに履歴を残すようにしています、dataシート列 L列に番号1が表示された場合のみSHEET4を印刷し、そうで無い場合SHEET5を刷したいですが、ご教授ください。 Sub rireki() Dim val(1 To 12) Dim lastRow As Long val(1) = Range("AH5").Value val(2) = Range("AJ3").Value val(3) = Range("AJ5").Value val(4) = Range("AK5").Value val(5) = Range("G2").Value val(6) = Range("AI5").Value val(7) = Range("B2").Value val(8) = Range("B5").Value val(9) = Range("E5").Value val(10) = Range("C3").Value val(11) = Range("V2").Value val(12) = Range("V3").Value Application.ScreenUpdating = False With Sheets("data") lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row End With Sheets("data").Range("A" & lastRow).Offset(1).Resize(, 12) = val Sheets("Sheet4").PrintOut Copies:=1, Collate:=True ActiveWorkbook.Save Application.ScreenUpdating = True End Sub

  • コンボボックスのvba 作成の仕方

    私は、月別にデータを作っています。なので、月ごとにデータを見られるようなボタンを作成したいです。 現在組んでいるマクロは、ボタン(普通の四角いもの)を押すごとに、翌月データをコピペするというものになっています。 (以下、現在のコード記載) Sub auto_open() Dim wkm As Long Dim wkn As Long Dim wkt As Variant Dim wks As Variant Dim dt As Date Dim mi As Integer dt = Date mi = Month(dt) wkt = Array(0, 10, 11, 12, 1, 2, 3, 4, 5, 6, 7, 8, 9) wks = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12) wkm = wkt(mi) Call Macro1(wkm) Sheets("住宅資金").Range("A3") = wks(mi) End Sub Sub Next_Month() Dim wks As Variant Dim dt As Date Dim mi As Integer wks = Array(0, 10, 11, 12, 1, 2, 3, 4, 5, 6, 7, 8, 9) If Sheets("住宅資金").Range("A3") = 12 Then wkm = 10 Else wkm = wks(Sheets("住宅資金").Range("A3") + 1) End If Call Macro1(wkm) wks = Array(0, 4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2, 3) Sheets("住宅資金").Range("A3") = wks(wkm) End Sub Sub Macro1(ByVal wkm As Long) With Sheets("入力") Sheets("住宅資金").Range("D5:D23").Value = .Range("C5:C23").Offset(, wkm - 1).Value Sheets("住宅資金").Range("J5:J23").Value = .Range("C28:C46").Offset(, wkm - 1).Value Sheets("住宅資金").Range("P5:P23").Value = .Range("T28:T46").Offset(, wkm - 1).Value Sheets("住宅資金").Range("O5:O23").Value = .Range("T5:T23").Offset(, wkm - 1).Value Sheets("住宅資金").Range("F5:F23").Value = .Range("O5:O23").Value Sheets("住宅資金").Range("L5:L23").Value = .Range("O28:O46").Value End With With Sheets("目標") Sheets("住宅資金").Range("C5:C23").Value = .Range("B4:B22").Offset(, wkm - 1).Value Sheets("住宅資金").Range("I5:I23").Value = .Range("B27:B45").Offset(, wkm - 1).Value End With With Sheets("前年同期") Sheets("住宅資金").Range("H5:H23").Value = .Range("C5:C23").Offset(, wkm - 1).Value Sheets("住宅資金").Range("N5:N23").Value = .Range("C28:C46").Offset(, wkm - 1).Value Sheets("住宅資金").Range("Q5:Q23").Value = .Range("T5:T23").Offset(, wkm - 1).Value End With End Sub さて、現在作りたいと思っているものを以下に記述します。 普通の四角いボタンではなく、コンボボックスを使用して、矢印(▼)を押すことによってリストが表れ、 「1月」に合わせたら1月のデータがコピペされる、「8月」に合わせたら8月のデータがコピペされる、というものを作りたいと思っています。 以下のような空欄の表を作成したシートがあります。        A    B    C   D 1      目標  実績  …   … 2 ○支所   3 △支所 4  ・ 5  ・ 6  ・ 別のシートに、手入力した月別のデータがあります。 空欄のシートのどこかにコンボボックスを作り、別シートの○月のデータを貼り付けられるようにしたいと思っています。 コンボボックスの作り方がわからず、後一歩のところでつまずいてしまいました。 知恵をお貸しください。 よろしくお願いいたします。

  • Excle 表紙作成マクロ

    今、添付しているような表紙を作成しているのですが、下のマクロで印刷からPDF化をしています。 ただ、毎回名前をつけなければいけないので、大変時間がかかります。 どなたか、楽な方法があるなら教えてください。 Sub Test() Dim c As Range Dim Ws As Worksheet Set Ws = Sheets("記録写真(表紙)") For Each c In Sheets("名前").Range("B1:B6") Ws.Range("A10").Value = c.Value '念のため DoEvents Ws.PrintOut Next End Sub

  • エクセル マクロ チェックボックス

    sheet1にチェックボックスが3つあり、マクロを実行するコマンドボタンが1つあります。 チェックボックスにレ点を入れることにより、sheet4のデータからsheet2にグラフを作成しようと考えてますが、エラーが出てしまい解決できません。 どのように訂正したらいいのか教えて頂けないでしょうか。 Private Sub CommandButton1_Click() Dim GraphRange As String Dim Graph As ChartObject Dim lastRow As Long Set Graph = Sheets("sheet2").ChartObjects.Add(150, 27, 350, 200) lastRow = Sheets("sheet4").Range("A" & Rows.Count).End(xlUp).Row GraphRange = Sheets("sheet4").Range(Cells(1, 1), Cells(lastRow, 1)).Value If Sheets("sheet1").CheckBox1.Value = True Then 'CheckBox1にチェックがあれば GraphRange = Sheets("sheet4").Range(Cells(1, 2), Cells(lastRow, 2)).Value End If If Sheets("sheet1").CheckBox2.Value = True Then 'CheckBox2にチェックがあれば GraphRange = Sheets("sheet4").Range(Cells(1, 3), Cells(lastRow, 3)).Value End If If CheckBox3.Value = True Then 'CheckBox3にチェックがあれば GraphRange = Sheets("sheet4").Range(Cells(1, 4), Cells(lastRow, 4)).Value End If Graph.Chart.ChartWizard Source:=Sheets("sheet4").Range(GraphRange).Value, _ Gallery:=xlLine, Format:=1, PlotBy:=xlColumns, _ CategoryLabels:=1, SeriesLabels:=1, HasLegend:=True End Sub

専門家に質問してみよう