- 締切済み
VBA : ピボットテーブルの作成
下記の内容でマクロを記述しましたが、「Set pvt = ・・・」の時点で、「実行エラー '13' 型が一致しません」とエラーが生じてしまいます。 どの部分がいけないのでしょうか？ よろしくお願い申し上げます。 ********************************************* Sub Macro1() Dim pvt As PivotTable Dim rngData As Range Dim shtName As String Dim mySht As Worksheet Sheets.Add 'シート名の変更 ActiveSheet.Name = "PVT123" For Each mySht In ActiveWorkbook.Worksheets shtName = mySht.Name If Left(shtName, 2) = "G-" Then mySht.Select Exit For End If Next '元データを変数に格納 lastRow = Cells(Rows.Count, 1).End(xlUp).Row lastClm = 1 Do Until Cells(1, lastClm).Value = "" lastClm = lastClm + 1 Loop lastClm = lastClm - 1 Set rngData = ActiveSheet.Range(Cells(1, 1), Cells(lastRow, lastClm)) 'ピボットテーブルの作成 Sheets("PVT777").Select Set pvt = _ ActiveWorkbook.PivotCaches.Add( _ SourceType:=xlDatabase, _ SourceData:=rngData). _ CreatePivotTable(TableDestination:=Range("A3")) ～以下省略～
- TENSAW
- お礼率79% (61/77)
- その他MS Office製品
- 回答数1
- ありがとう数0
- みんなの回答 （1）
- 専門家の回答
みんなの回答
- bin-chan
- ベストアンサー率33% (1403/4213)
関連するQ&A
- EXCELマクロのピボットテーブル
G列に名前、０列に点数があります。 ピボットテーブルで 名前, 平均／点数, 個数／点数 と横に表記したいのですが、 名前, 平均／点数, 個数／点数 と2行分かれて表記されます。 マクロは以下です。どこをどう変更したらよいでしょうか。 'ピボットテーブル作成 Dim pvt As PivotTable Dim rngData As Range Set rngData = ActiveSheet.Range("A1").CurrentRegion Sheets.Add Set pvt = _ ActiveWorkbook.PivotCaches.Add( _ SourceType:=xlDatabase, _ SourceData:=rngData). _ CreatePivotTable(TableDestination:=Range("A3")) With pvt .PivotFields("名前").Orientation = xlRowField .PivotFields("点数").Orientation = xlDataField pvt.DataFields(1).Function = xlAverage With pvt .PivotFields("名前").Orientation = xlRowField .PivotFields("点数").Orientation = xlDataField pvt.DataFields(1).Function = xlCount End With End With '
- ベストアンサー
- オフィス系ソフト
- EXCELマクロ ピボットテーブルで平均値
A列～O列にデータがあって、G列に名前、O列に点数が入力されています。列数は変化しませんが、行数が変化します。 可変する行数で、名前別の平均値をマクロで出すにはどうすればよいですか？ ネット検索の結果、以下のマクロで合計は出るのですが、平均値が出せません。 CreatePivotTable(TableDestination:=Range("A3"))のA3の意味も教えていただけないでしょうか。 よろしくお願いします。 Sub Macro1() Dim pvt As PivotTable Dim rngData As Range Set rngData = ActiveSheet.Range("A1").CurrentRegion Sheets.Add Set pvt = _ ActiveWorkbook.PivotCaches.Add( _ SourceType:=xlDatabase, _ SourceData:=rngData). _ CreatePivotTable(TableDestination:=Range("A3")) With pvt .PivotFields("名前").Orientation = xlRowField .PivotFields("点数").Orientation = xlDataField End With
- ベストアンサー
- Excel（エクセル）
- VBA 最終行を選んだシートにコピーする。
VBAど初心者です。どうしても最終行のデータを選んだシートにコピーできません。 LastRow.Selectのところで、止まってしまいます。どのように行を設定していいのかさっぱりわかりません。どなたか、ご指導のほどよろしくお願いします。 Sub copy_last_line() Dim LastRow As Long Sheets("Sheet1").Select LastRow = Cells(Rows.Count, 1).End(xlUp).Row LastRow.Select Selection.Copy Sheets("Sheet2").Select Range("A1").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("A1").Select End Sub
- ベストアンサー
- Visual Basic
- エクセルVBAで困っています。
エクセルでSheet1でSheet2に各銀行の出納帳を作りそこから各項目ごとに別Sheetに振り分けたいと思っています。 ある方にエクセルVBAで作って頂いたのですが、最初作って頂いた時の項目は会費、会議費、事務費の３つでした。その項目を９つに増やしたいと思っています。又、全てのSheetで１行目には銀行名や項目名を入れたいので２行目から日付、内容・・・といったように入力したいです。そうした場合、どこをどう変更したらよいのか分かりません。自分がわかる範囲で（適当ですが）挑んでみたのですが、私自体VBAについて全く無知のため何が何だかサッパリです。どなたか教えて頂くことはできないでしょうか。ちなみに文字数に制限があったため改行やスペースなどは入れていません。見難いとは思いますがよろしくお願いします。どうか皆様のお知恵を貸して頂けると幸いです。 Option Explicit Sub Teller() '【考え方】Sheet1とSheet2を入力と考える。 'マクロを実行したときに、Sheet1,2を元に、項目別に振り分ける。 Const BankName1 As String = "○銀行" Const BankName2 As String = "(チェック)銀行" Const tempSheet As String = "一時シート" Dim classify(9) As String Dim title(5) As String Dim i As Long Dim j As Long Dim lastRow1 As Long Dim lastRow2 As Long Dim findUpper As Long Dim findLower As Long Dim keyword As String Dim ws As Worksheet Dim Bank1 As Worksheet Dim Bank2 As Worksheet Dim Temp As Worksheet Set Bank1 = Worksheets(BankName1) Set Bank2 = Worksheets(BankName2) '【振り分ける項目名】 classify(1) = "会費" classify(2) = "会議費" classify(3) = "事務費" classify(4) = "事業費" classify(5) = "研修費" classify(6) = "報償費" classify(7) = "慶弔費" classify(8) = "予備費" classify(9) = "積立金" '【1行目に記載する見出し】 title(1) = "日付" title(2) = "内容" title(3) = "収入" title(4) = "支出" title(5) = "残高" '画面更新を停止 Application.ScreenUpdating = False '最終行取得 Bank1.Select lastRow1 = Cells(Rows.Count, 1).End(xlUp).Row Bank2.Select lastRow2 = Cells(Rows.Count, 1).End(xlUp).Row 'シートを作る For i = 1 To 3 Call MakeNewSheet_As_ThisName(classify(i)) For j = 1 To 5 Cells(1, j) = title(j) Next j Next i Call MakeNewSheet_As_ThisName(tempSheet) Cells.ClearContents Set Temp = Worksheets(tempSheet) '一時シートに、銀行1のデータと銀行2のデータをコピーする。 Bank1.Select Bank1.Range(Cells(3, 1), Cells(lastRow1, 5)).Copy Temp.Select Temp.Range(Cells(1, 1), Cells(lastRow1 - 2, 5)).PasteSpecial Bank2.Select Range(Cells(3, 1), Cells(lastRow2, 5)).Copy Temp.Select Cells(lastRow1 - 1, 1).PasteSpecial 'ソートする。 '第一優先キー：B列。[項目]昇順。 '第二優先キー：A列。[日付]昇順。 Range("A1:E" & (lastRow1 + lastRow2 - 4)).Select With ActiveWorkbook.Worksheets(tempSheet).Sort .SortFields.Clear .SortFields.Add Key:=Range("B1:B" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第一キー .SortFields.Add Key:=Range("A1:A" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第二キー .SetRange Range("A1:E" & (lastRow1 + lastRow2 - 4)) .Apply End With For i = 1 To 3 keyword = classify(i) findUpper = 0 findLower = 0 '上から探す For j = 1 To lastRow1 + lastRow2 - 4 Step 1 If Cells(j, 2) = keyword Then findUpper = j Exit For End If Next j If findUpper > 0 Then '下から探す For j = lastRow1 + lastRow2 - 4 To 1 Step -1 If Cells(j, 2) = keyword Then findLower = j Exit For End If Next j 'コピー Range(Cells(findUpper, 1), Cells(findLower, 5)).Copy Sheets(keyword).Select Range("A2").Select ActiveSheet.Paste Range("B2:B" & 2 + (findLower - findUpper)).Delete Shift:=xlToLeft Sheets(tempSheet).Select End If Next i '一時シートの削除 Application.DisplayAlerts = False Temp.Delete Application.DisplayAlerts = True 'アクティブセルをA1にしておく For Each ws In Worksheets Sheets(ws.Name).Select 'シート選択 Application.CutCopyMode = False Range("A1").Select Next ws Bank1.Select '画面更新を行う Application.ScreenUpdating = True MsgBox "実行しました" End Sub Sub MakeNewSheet_As_ThisName(ByVal GivenName As String) 'シートの有無を確認し、無ければ作る Dim exist_flag As Boolean Dim ws As Worksheet exist_flag = False For Each ws In Worksheets If UCase(ws.Name) = UCase(GivenName) Then 'シートが存在する場合 exist_flag = True Exit For End If Next ws 'シートを作成 If GivenName = "" Then MsgBox "空白名のシートは作れません。" ElseIf exist_flag = False Then Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = GivenName End If Sheets(GivenName).Select 'シート選択 End Sub
- ベストアンサー
- オフィス系ソフト
- ピボテ 作成と同時名前を指定する方法
エクセルｖｂａでピボットテーブルの作成と同時に ピボットテーブルの名前を付ける方法はありますか？ Dim pvt As PivotTable Dim rngData As Range '元データを変数に格納 Set rngData = ActiveSheet.Range("A1").CurrentRegion Set pvt = _ ActiveWorkbook.PivotCaches.Add( _ SourceType:=xlDatabase, _ SourceData:=rngData). _ CreatePivotTable(TableDestination:=Range("c3")) これでピボットテーブルの作成は出来ますが、 名前は「ピボットテーブル1」と勝手についてしまいます。 作成と同時名前を指定する方法を教えてください。 名前は「test」としたいです。 今は、 Sub Sample1() Dim i As Integer For i = 1 To ActiveSheet.PivotTables.Count ActiveSheet.PivotTables.Item(i).Name = "test" Next End Sub としています。
- ベストアンサー
- オフィス系ソフト
- ExcelVBA 変数を使って項目軸ラベルを追加するには
Excel2000 VBAで 一度作ったグラフに 項目軸ラベルを追加しようとすると エラーが出ます． Dim MyWorkBookName As String Dim MySheetName As String Dim LastRow As Integer MyWorkBookName = ActiveWorkbook.Name MySheetName = ActiveSheet.Name LastRow= 52 With ActiveChart .SeriesCollection(1).XValues = _ Workbooks(MyWorkBookName). _ Worksheets(MySheetName). _ Range(Cells(2, 6), Cells(LastRow, 6)) End With 変数を使って表したいのですが．．．
- ベストアンサー
- オフィス系ソフト
- 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
- 締切済み
- Visual Basic
- ピボットテーブルのマクロでシートを指定、連続
過去問？も確認しましたが、うまく行きません。 マクロの自動記録で作成し、TableDestination:=Sheets("Sheet1").Range("A1"),、と変更しましたが、 With ActiveSheet.PivotTables("ピボットテーブル1")のところで止まってしまいます。また、最後の行の Application.Run "'Pivot for 東京.xls'!Macro3"は、正しい記述でしょうか？ よろしくお願いします。 Workbooks.Open Filename:= _ "C:\Documents and Settings\ \デスクトップ\Access DB\Pivot for 東京.xls" Sheets("DSG").Select Columns("A:AZ").Select Range("Q1").Activate Selection.Delete Shift:=xlToLeft Range("A1").Select Sheets("GSG").Select Columns("A:AZ").Select Range("P1").Activate Selection.Delete Shift:=xlToLeft Range("A1").Select Sheets("ダート").Select Columns("A:AZ").Select Range("W1").Activate Selection.Delete Shift:=xlToLeft Range("A1").Select Sheets("芝").Select Columns("A:AZ").Select Range("AQ1").Activate Selection.Delete Shift:=xlToLeft Range("A1").Select Windows("Pivot01.xls").Activate Sheets("G").Select Range("E1").Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlToRight)).Select ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _ "G!R1C5:R8594C11").CreatePivotTable TableDestination:=Sheets("Sheet1").Range("A1"), TableName _ :="ピボットテーブル1" With ActiveSheet.PivotTables("ピボットテーブル1") '------------＞ここで止まります .NullString = "0" .SmallGrid = False End With ActiveSheet.PivotTables("ピボットテーブル1").AddFields RowFields:="騎手名", _ ColumnFields:=Array("距離", "着順") With ActiveSheet.PivotTables("ピボットテーブル1").PivotFields("着順") .Orientation = xlDataField .Caption = "データの個数 : 着順" .Function = xlCount End With Application.CommandBars("PivotTable").Visible = False Windows("Pivot01.xls").Activate Sheets("1").Select Columns("A:DD").Select Selection.Delete Shift:=xlToLeft Sheets("D").Select Range("E1").Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlToRight)).Select ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _ "D!R1C5:R9508C11").CreatePivotTable TableDestination:=Sheets("Sheet1").Range("A1"), TableName _ :="ピボットテーブル2" ActiveSheet.PivotTables("ピボットテーブル2").SmallGrid = False ActiveSheet.PivotTables("ピボットテーブル2").AddFields RowFields:="騎手名", _ ColumnFields:=Array("距離", "着順") With ActiveSheet.PivotTables("ピボットテーブル2").PivotFields("着順") .Orientation = xlDataField .Caption = "データの個数 : 着順" .Function = xlCount End With Application.CommandBars("PivotTable").Visible = False Windows("Pivot01.xls").Activate Sheets("1").Select Columns("A:DD").Select Selection.Delete Shift:=xlToLeft Sheets("GSG").Select Range("E1").Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlToRight)).Select ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _ "GSG!R1C5:R81C11").CreatePivotTable TableDestination:=Sheets("Sheet1").Range("A1"), TableName _ :="ピボットテーブル3" With ActiveSheet.PivotTables("ピボットテーブル3") .NullString = "0" .SmallGrid = False End With ActiveSheet.PivotTables("ピボットテーブル3").AddFields RowFields:="騎手名", _ ColumnFields:="着順" With ActiveSheet.PivotTables("ピボットテーブル3").PivotFields("着順") .Orientation = xlDataField .Caption = "データの個数 : 着順" .Function = xlCount End With Application.CommandBars("PivotTable").Visible = False Windows("Pivot01.xls").Activate Application.Run "'Pivot for 東京.xls'!Macro3" End Sub
- ベストアンサー
- その他MS Office製品
- VBA（エクセル）で教えて下さい。開いていないBOOKの貼り付け
VBA（エクセル）で教えて下さい。開いていないBOOKのシートを開いているBOOKのシートに貼り付けで、開いているBOOKから開いていないBOOK名を指定したいのですが、 現在開いているエクセルです。 SHEETS(Type)のRANGE（A1）に閉じているBOOK名を入力します。 SHEETS（In）に閉じているBOOKのSHEETSを貼り付けたいのですが、 Ex = Sheets("Type").Range("A1") が無いと閉じているEx.xlsを貼り付けます。 このExと言うBOOK以外も多々コピーしたいのですが、どのように書けば良いか分からず、 是非、教えて下さい。 Sub a1() Dim wsSrc As Worksheet, WS As Worksheet Dim PasteR As Range Dim x As Long Sheets("In").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select 'If Worksheets(1).Name = "STEP1" Then ' Worksheets(1).Activate ' Cells.ClearContents ' Else 'Worksheets.Add(Before:=Worksheets(1)).Name = "一覧" 'End If Ex = Sheets("Type").Range("A1") Set wsSrc = ActiveSheet Workbooks.Open "C:\WINDOWS\デスクトップ\test\Ex.xls" For Each WS In Worksheets x = WS.Range("A1").CurrentRegion.Rows.Count If WS.Index = 1 Then Set PasteR = wsSrc.Range("A1") Else Set PasteR = wsSrc.Range("A65536").End(xlUp).Offset(1) End If WS.Range(WS.Cells(1, 1), WS.Cells(x, 44)).Copy PasteR Set PasteR = Nothing Next ActiveWorkbook.Close False Set wsSrc = Nothing End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBA どうしても動きません。
お世話になります。 なかなか上達しない超初心者です。 ↓↓ですが、Activesheetにすると動くのに、シート名を元々存在するシート”実験"に指定すると動きません（データ内容はまったく同じで、A列に色んな名前が入っていて、重複しているとC列に重複と入力します）。 2日間試行錯誤したのですが、やっぱり動かず・・・ ちなみに、Activateにするとアクティブになるし、CurrentRegionも選択できるのに なんでうごかないんでしょうか・・・ 何卒ご指導くださいませ。よろしくお願いいたします！！！！！！ Sub Test2() With Sheets("実験").Range("A1").CurrentRegion Dim i As Long Dim LastRow As Long LastRow = Range("A" & Rows.Count).End(xlUp).Row For i = 1 To LastRow If WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1)) > 1 Then Cells(i, 3) = "重複" End If Next i End With End Sub Sheets("実験")をActivesheetに変えると別のシートがしっかり動いてくれます・・・が、なんとしてでも”実験”シートに動いていただきたいです・・・。
- ベストアンサー
- Visual Basic
補足
lastRow:5813 lastClm:36 です。よろしくお願いいたします。