Excel VBA質問箱 IV

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

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


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

198 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


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

β - 16/10/8(土) 21:57 -


	引用なし

	パスワード

▼ちろさん：

とりあえず一例です。
不具合あれば指摘願います。

Sub Test()
　　Dim myRange As Range　　'画像を配置するセル範囲
　　Dim myPic As Variant

　　Set myRange = ActiveCell.MergeArea　　'このセル範囲に収まるように画像を縮小する
　　
　　myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
　　If VarType(myPic) = vbBoolean Then Exit Sub

　　With ActiveSheet.Pictures.Insert(myPic)
　　　　.ShapeRange.LockAspectRatio = msoTrue
　　　　.Cut
　　　　ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
　　　　DoEvents
　　　　With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
　　　　　　.Width = myRange.Width
　　　　　　If .Height > myRange.Height Then .Height = myRange.Height
　　　　　　.Top = myRange.Top + (myRange.Height - .Height) / 2
　　　　　　.Left = myRange.Left + (myRange.Width - .Width) / 2
　　　　End With
　　End With
　　
End Sub

・ツリー全体表示


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

β - 16/10/8(土) 21:31 -


	引用なし

	パスワード

▼ちろさん：

>残念ながら未だに完成しておりません。
>何処が悪いのでしょうか。
>

どういう状況なのかを明確にしていただければ、皆さん、アドバイスしやすいと思います。

Set sp = Range(sp.TopLeftCell, sp.BottomRightCell)

ここで、実行時エラーになったのでしょうか？
であれば、左辺に右辺のオブジェクトを代入しているわけですが、その左辺の中の sp ですけど、

・まず、sp には事前に何も入れていませんよね。Nothiong ですね。
　Nothing.TopLEftCell 等、具合悪いですよね。
・次に Dim sp As Shape と規定してますよね。
　でも、このコードでセットしようとしているのは Range オブジェクトですよね。
　これまた、具合悪いですよね。

まず、そのあたりを正常にしてから、実行し、なおかつ不具合が出たら、ＳＯＳだされたらいいと
思います。

・ツリー全体表示


	【78491】Re:ピボット作成

マナ - 16/10/8(土) 13:52 -


	引用なし

	パスワード

▼パニックさん：
>AのBookからあるデータシートを新しいBookにコピーして
>ピボットを作成したいです。

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

>VBAではなく、普通にやるとピボットは組めます。

考え方をかえて、こんな感じではだめなのでしょうか。
これならマクロ使うまでもないかもしれません。

１）ひな形Book（データテーブルとピボット）を手動で作成しておき
２）AのBookのデータをひな形に転記
３）ピボットを更新
４）ひな形を別名で保存

・ツリー全体表示


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

ちろ - 16/10/8(土) 11:46 -


	引用なし

	パスワード

βさん
アドバイスいただきありがとうございました。

ご紹介いただいたページや他のページを参考に試行錯誤してますが
残念ながら未だに完成しておりません。
何処が悪いのでしょうか。

ご教授いただけないでしょうか。

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
　 Dim sp As Shape

　
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
　
　
　'----------------------追加--------------------------------------------
'For Each sp In ActiveSheet.Shapes
　　Set sp = Range(sp.TopLeftCell, sp.BottomRightCell)
　　　　　 sp.Select
　　　　　　Selection.Cut
　　　　　　ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
　　　　　　DoEvents
　　　　　　With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
　　　　　　　　.Left = ActiveCell.Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置
　　　　　　　　.Top = ActiveCell.Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置
　　　　　　End With
' Next

'--------------------------------------------------------------------
　　　
End With

Application.ScreenUpdating = True
Cancel = True

End Sub

・ツリー全体表示


	【78489】Re:ピボット作成

γ - 16/10/7(金) 20:36 -


	引用なし

	パスワード

▼パニックさん：
>下記のようなエラーが出ます。

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

繰り返し確認しますが、
「どの行で」エラーになるのですか？
その行で使っているフィールド名が正しくないのです。

お尋ねしたことに、きちんと回答してください。

・ツリー全体表示


	【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ってマクロなんですが？

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

・ツリー全体表示


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

198 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free