Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

199 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【78488】Re:ピボット作成

パニック - 16/10/7(金) 9:29 -


	引用なし

	パスワード

下記のようなエラーが出ます。
VBAではなく、普通にやるとピボットは組めます。
何がいけないんでしょうか？
VBAでもR1C1形式で指定するとうまくいきますが、都度、行数が変わるので
その形式は辞めたいです。

【エラーメッセージ】
そのピボットテーブルのフィールド名が正しくありません。
ピボットテーブルを作成するにはラベルのついた列でリストとして編成されたデータを使用する必要があります。

宜しくお願いします。

・ツリー全体表示


	【78487】Re:ピボット作成

γ - 16/10/6(木) 21:06 -


	引用なし

	パスワード

＞Setでエラーになります。
そこでエラーになる可能性は低いです。

どの行でエラーがでて、
なんというエラーメッセージなのかを正確に示して下さい。
あなたのPCの画面はこちらからは見えませんので。

・ツリー全体表示


	【78486】Re:ピボット作成

パニック - 16/10/6(木) 19:25 -


	引用なし

	パスワード

色々と検索し下記に変更してもエラーになってしまいます。

Dim MyRow As Long

MyRow = Range("A65536").End(xlUp).row

・・・
SourceData:="1.尺度ごとの集計!R3C1:R" & MyRow & "C5"

どなたかお助けください！
お願いします。

・ツリー全体表示


	【78485】ピボット作成

パニック - 16/10/6(木) 17:11 -


	引用なし

	パスワード

AのBookからあるデータシートを新しいBookにコピーして
ピボットを作成したいです。

毎回、範囲が可変するので変数にいれたいのですがうまくいきません。
欲しい範囲は下記なのですが　　
'Range("A3:E3").Select
'Range(Selection, Selection.End(xlDown)).Select

Sheets("1.尺度ごとの集計").Range("A3").CurrentRegionで範囲は大きくなりますが
表毎指定したほうが楽かと思い下記のように書きました。

Setでエラーになります。
または、SourceData:に直接書き込んでもそこでエラーになります。
書き方が間違っているのでしょうか？
ご教示お願いします。

Sub Pivot()
'
'
　　Dim src As Range 'データ範囲
'
　　Sheets("1.尺度ごとの集計").Select
　　Sheets("1.尺度ごとの集計").Copy
　　'Range("A3:E3").Select
　　'Range(Selection, Selection.End(xlDown)).Select
　　Sheets.Add
　　
　　Set src = Sheets("1.尺度ごとの集計").Range("A3").CurrentRegion
　　
　　ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=src _
　　　　, version:=xlPivotTableVersion15).CreatePivotTable _
　　　　TableDestination:="Sheet2!R3C1", TableName:="ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1", DefaultVersion _
　　　　:=xlPivotTableVersion15
　　Sheets("Sheet2").Select
　　Cells(3, 1).Select
　　ActiveSheet.PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").AddDataField ActiveSheet.PivotTables( _
　　　　"ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotFields("個人識別番号"), "合計 / 個人識別番号", xlSum
　　With ActiveSheet.PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotFields("合計 / 個人識別番号")
　　　　.Caption = "データの個数 / 個人識別番号"
　　　　.Function = xlCount
　　End With
　　With ActiveSheet.PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotFields("事業署名")
　　　　.Orientation = xlRowField
　　　　.Position = 1
　　End With
　　With ActiveSheet.PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotFields("部署名")
　　　　.Orientation = xlRowField
　　　　.Position = 2
　　End With
　　With ActiveSheet.PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotFields("配属(配属先がある方のみ)")
　　　　.Orientation = xlRowField
　　　　.Position = 3
　　End With
　　ActiveSheet.PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").TableStyle2 = "PivotStyleMedium5"
　　ActiveSheet.PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").RowAxisLayout xlTabularRow
　　ActiveSheet.PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").ColumnGrand = False
　　ActiveSheet.PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotFields("事業署名").Subtotals = Array( _
　　　　False, False, False, False, False, False, False, False, False, False, False, False)
　　ActiveSheet.PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotFields("部署名").Subtotals = Array( _
　　　　False, False, False, False, False, False, False, False, False, False, False, False)
End Sub

・ツリー全体表示


	【78484】Re:画像をJPEGに変換

β - 16/10/5(水) 22:08 -


	引用なし

	パスワード

▼ちろさん：

こんなページがありました。

ht p://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1129079816

・ツリー全体表示


	【78483】画像をJPEGに変換

ちろ - 16/10/5(水) 21:17 -


	引用なし

	パスワード

選択したセルの大きさに合わせ圧縮した画像（JPEG)を貼り付けたいのですが
JPEG変換できず苦戦しております。
いろいろなサンプルを参考にしておりますがエラーで止まってしまいます。

下記のコードは画像貼り付けできますがJPEG変換できません。

私の構想は、一度貼り付けた画像を切り取ってJPEGで貼り付けるといった手順でコードを書きたいのですが・・・

アドバイス頂きたくお願いいたします。

Public Sub CCC()

Dim myRange As Range '画像を配置するセル範囲
Dim rX, rY As Double
Dim myDhape, myPic As Variant
Dim Cancel As Boolean
Dim SpObj As Object
　
　
myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
If VarType(myPic) = vbBoolean Then Exit Sub

Set myRange = ActiveCell.MergeArea 'このセル範囲に収まるように画像を縮小する
　　　
Application.ScreenUpdating = False

With ActiveSheet.Pictures.Insert(myPic).ShapeRange
　 rX = myRange.Width / .Width
　 rY = myRange.Height / .Height
　If rX > rY Then
　　.Height = .Height * rY
　　Else
　　.Width = .Width * rX
　End If
.Left = ActiveCell.Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置
.Top = ActiveCell.Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置
　　　
End With

Application.ScreenUpdating = True
Cancel = True

End Sub

・ツリー全体表示


	【78482】Re:文字入力すると次のセルに移動するVBA

洋子 - 16/10/3(月) 12:02 -


	引用なし

	パスワード

▼β さん：
>▼洋子さん：
>
> たとえば以下のように統合する手はありますね。
> さらに、別の処理も、今後加わるかもしれませんので、私がアップしたブロック、
> 該当なかったらExit Sub としていたところを　該当あれば実行に変えておきました。
>
> なお、●のところ、貼付　内でこのシートのセルを触っているのかどうかわかりませんが
> もし、触っている場合、無駄なイベント連鎖が発生しますし、触り方によっては
> 無限ループに陥りますので、イベント発生の抑止/再開　をいれておきました。
>
>Private Sub Worksheet_Change(ByVal Target As Range)
>　　Const TgCel = "N5"　　' <-- 特定セルを指定
>　　Dim adr As Variant
>　　Dim a As Range
>　　Dim x As Long
>
>　　If Not Intersect(Range(TgCel), Target) Is Nothing Then
>　　　　If Range(TgCel) <> "" Then
>　　　　　　Application.EnableEvents = False　　'●
>　　　　　　'MsgBox "セル" & TgCel & " に値が入力されました。"
>　　　　　　Call 貼付　　' <-- 実行するマクロ指定
>　　　　　　Application.EnableEvents = True　　 '●
>　　　　End If
>　　End If
>
>　　adr = Array("G8", "I10", "K14", "M18", "H24", "K31", "N27", "G8")　 '★
>　　Set a = Range(Join(adr, ","))
>　　If Not Intersect(Target(1), a) Is Nothing Then
>　　　　x = WorksheetFunction.Match(Target(1).Address(False, False), adr, 0)
>　　　　Range(adr(x)).Select
>　　End If
>　　
>End Sub

β さん
有難うございます。
完成いたしました。感激です・・・・

・ツリー全体表示


	【78481】Re:エクセルからの削除、リネーム後の保存

Todd - 16/10/1(土) 3:18 -


	引用なし

	パスワード

不明瞭なご説明で申し訳御座いませんでした。

ご回答頂いた内容で解決致しました。
有難うございます。

以上

・ツリー全体表示


	【78480】Re:文字入力すると次のセルに移動するVBA

β - 16/9/30(金) 18:56 -


	引用なし

	パスワード

▼洋子さん：

たとえば以下のように統合する手はありますね。
さらに、別の処理も、今後加わるかもしれませんので、私がアップしたブロック、
該当なかったらExit Sub としていたところを　該当あれば実行に変えておきました。

なお、●のところ、貼付　内でこのシートのセルを触っているのかどうかわかりませんが
もし、触っている場合、無駄なイベント連鎖が発生しますし、触り方によっては
無限ループに陥りますので、イベント発生の抑止/再開　をいれておきました。

Private Sub Worksheet_Change(ByVal Target As Range)
　　Const TgCel = "N5"　　' <-- 特定セルを指定
　　Dim adr As Variant
　　Dim a As Range
　　Dim x As Long

　　If Not Intersect(Range(TgCel), Target) Is Nothing Then
　　　　If Range(TgCel) <> "" Then
　　　　　　Application.EnableEvents = False　　'●
　　　　　　'MsgBox "セル" & TgCel & " に値が入力されました。"
　　　　　　Call 貼付　　' <-- 実行するマクロ指定
　　　　　　Application.EnableEvents = True　　 '●
　　　　End If
　　End If

　　adr = Array("G8", "I10", "K14", "M18", "H24", "K31", "N27", "G8")　 '★
　　Set a = Range(Join(adr, ","))
　　If Not Intersect(Target(1), a) Is Nothing Then
　　　　x = WorksheetFunction.Match(Target(1).Address(False, False), adr, 0)
　　　　Range(adr(x)).Select
　　End If
　　
End Sub

・ツリー全体表示


	【78479】Re:エクセルからの削除、リネーム後の保存

β - 16/9/30(金) 17:37 -


	引用なし

	パスワード

▼Todd さん：

コメントした通り、必要なファイルフルパス文字列を作成して処理すればいいので
どのあたりに困っておられるのかわからないのですが、一応、サンプルとして。

Sub Sample1()
　　Dim fso As Object
　　Dim oPath As String
　　Dim nPath As String
　　
　　Set fso = CreateObject("Scripting.FileSystemObject")
　　
　　oPath = "C:\古いフォルダ\元のファイル.txt"
　　nPath = "c:\新しいフォルダ\元のファイル" & Format(Now, "yyyymmddsshhnn") & ".txt"
　　
　　On Error Resume Next
　　fso.deletefile nPath　　'移動先の同名のファイルを削除
　　On Error GoTo 0
　　
　　fso.movefile oPath, nPath
　　
End Sub

Sub Sample2()
　　Dim oPath As String
　　Dim nPath As String
　　
　　
　　oPath = "C:\古いフォルダ\元のファイル.txt"
　　nPath = "c:\新しいフォルダ\元のファイル" & Format(Now, "yyyymmddsshhnn") & ".txt"
　　
　　On Error Resume Next
　　Kill nPath　'移動先の同名のファイルを削除
　　On Error GoTo 0
　　
　　Name oPath As nPath
　　
End Sub

・ツリー全体表示


	【78478】Re:エクセルからの削除、リネーム後の保存

β - 16/9/30(金) 14:29 -


	引用なし

	パスワード

▼Todd さん：

FSO処理であれば、

FSO.MoveFile "元のフォルダパス文字列\元のファイル名","新しいフォルダパス文字列\新しいファイル名"

ＶＢＡ標準のNAME処理であれば、

Name "元のフォルダパス文字列\元のファイル名" As "新しいフォルダパス文字列\新しいファイル名"

といったように、新しいファイルフルパス文字列を与えればいいのですが、
具体的にどこがわからないのでしょう？

なお、FSOにしろName にしろ、移動先に同名ファイルがあれば失敗しますので
そのための手当も必要ですけど、とにかく、まず移動させるということに絞って進めたらいいと思います。

・ツリー全体表示


	【78477】Re:文字入力すると次のセルに移動するVBA

洋子 - 16/9/30(金) 13:53 -


	引用なし

	パスワード

▼β さん：
>▼洋子さん：
>
>>自力で何とかできました。
>
>それは祝着です。
>用済みですけど、アップしようとしていたコードを参考までに。
>
>シートモジュールに。
>★のところは、好きなセルを好きな順番で。
>最初のセルを最後にも記述してください。（アップしたコード例ではG8)
>
>Private Sub Worksheet_Change(ByVal Target As Range)
>　　Dim adr As Variant
>　　Dim a As Range
>　　Dim x As Long
>　　
>　　adr = Array("G8", "I10", "K14", "M18", "H24", "K31", "N27", "G8")　 '★
>　　Set a = Range(Join(adr, ","))
>　　If Intersect(Target(1), a) Is Nothing Then Exit Sub
>　　x = WorksheetFunction.Match(Target(1).Address(False, False), adr, 0)
>　　Range(adr(x)).Select
>　　
>End Sub

β さん：最後までご指導有難うございます。
因みに
Private Sub Worksheet_Change(ByVal Target As Range)を使ったコードが二つあるためエラーとなるようです。回避方法ありますか？ちなみ下記子どとなります。

Private Sub Worksheet_Change(ByVal Target As Range)
Const TgCel = "N5" ' <-- 特定セルを指定
If Not Intersect(Range(TgCel), Target) Is Nothing Then
If Range(TgCel) <> "" Then
'MsgBox "セル" & TgCel & " に値が入力されました。"
Call 貼付 ' <-- 実行するマクロ指定
End If
End If
End Sub
宜しくお願いいたします。

・ツリー全体表示


	【78476】Re:エクセルからの削除、リネーム後の保存

Todd - 16/9/30(金) 7:29 -


	引用なし

	パスワード

対象ファイルをAフォルダからBフォルダに移動することは出来ました。
次にBフォルダに移動させたファイルのファイル名を"エクセル名と日時"に
変更したいのですが、どうすればよいでしょうか？

Sub ファイル移動とリネーム
　　Dim fso As Object
　　Dim strSrc As String
　　Dim strDst As String
　　
　　Set fso = CreateObject("Scripting.FileSystemObject")
　　strSrc ="C:保存場所/対象ファイル
　　strDst ="C:移動場所/対象ファイル
　　
　　Set fso = Nothing

　　Name "C:移動場所/対象ファイル" as "ここをエクセルファイル名と日時にしたい"

お手数をお掛け致しますが、宜しくお願い致します。

以上

・ツリー全体表示


	【78475】Re:文字入力すると次のセルに移動するVBA

β - 16/9/29(木) 14:15 -


	引用なし

	パスワード

▼洋子さん：

>自力で何とかできました。

それは祝着です。
用済みですけど、アップしようとしていたコードを参考までに。

シートモジュールに。
★のところは、好きなセルを好きな順番で。
最初のセルを最後にも記述してください。（アップしたコード例ではG8)

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim adr As Variant
　　Dim a As Range
　　Dim x As Long
　　
　　adr = Array("G8", "I10", "K14", "M18", "H24", "K31", "N27", "G8")　 '★
　　Set a = Range(Join(adr, ","))
　　If Intersect(Target(1), a) Is Nothing Then Exit Sub
　　x = WorksheetFunction.Match(Target(1).Address(False, False), adr, 0)
　　Range(adr(x)).Select
　　
End Sub

・ツリー全体表示


	【78474】Re:文字入力すると次のセルに移動するVBA

洋子 - 16/9/29(木) 14:10 -


	引用なし

	パスワード

▼β さん：
>▼洋子さん：
>
>>VBAをお願いします
>
>>マクロ以外でお願いします。
>
>・・・・・・
>
>VBAってマクロなんですが？

ご返事有難うございます。
自力で何とかできました。

・ツリー全体表示


	【78473】Re:文字入力すると次のセルに移動するVBA

β - 16/9/29(木) 13:59 -


	引用なし

	パスワード

▼洋子さん：

>VBAをお願いします

>マクロ以外でお願いします。

・・・・・・

VBAってマクロなんですが？

・ツリー全体表示


	【78472】文字入力すると次のセルに移動するVBA

洋子 - 16/9/29(木) 12:28 -


	引用なし

	パスワード

A1セルに文字を入力するとC2へ移動するようなVBAをお願いします。
入力課所は7か所ぐらいです。
マクロ以外でお願いします。

・ツリー全体表示


	【78471】Re:セルに文字列が入力されたらマクロの...

北風 - 16/9/27(火) 11:34 -


	引用なし

	パスワード

▼β さん：
>▼北風さん：
>
>１つのモジュールに同じ名前のプロシジャを書くことはできません。
>今、２つ（あるいはもっとたくさん？）あるWorksheet_Changをすべてアップしてください。

β さんお力沿い有難うございます。

Workshee Opendeで問題解決できました。
お手数かけました有難うございます・

・ツリー全体表示


	【78470】Re:セルに文字列が入力されたらマクロの...

β - 16/9/27(火) 11:04 -


	引用なし

	パスワード

▼北風さん：

１つのモジュールに同じ名前のプロシジャを書くことはできません。
今、２つ（あるいはもっとたくさん？）あるWorksheet_Changをすべてアップしてください。

・ツリー全体表示


	【78469】Re:セルに文字列が入力されたらマクロの...

北風 - 16/9/27(火) 10:03 -


	引用なし

	パスワード

▼独覚さん：
>▼北風さん：
>>『コンパイルエラー
>>名前が適切ではありません　Worksheet_Chang』　となります。
>
>おなじワークシートモジュール内に
>Private Sub Worksheet_Change(ByVal Target As Range)
>が複数ありませんか？

セルに入力したら次の指定セルに移動するコードがあります。
回避方法がわかりません

・ツリー全体表示


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

199 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free