Excel VBA質問箱 IV

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

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


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

197 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【78528】Re:複数の文字列を置換したい

β - 16/10/29(土) 14:33 -


	引用なし

	パスワード

▼naoko さん：

↑

この方式は別掲示板ですが syさんという方の回答コードを借りました。
ようは、いかに効率的な数式を組み立てることができるかどうかがポイントです。
この方式でも数式がおそまつなら、処理時間の足を引っ張るでしょうね。

数式の優劣にはかかわらず　一定の、まずまずの変換を行う方法としては
変換要素をDictionaryに格納し、変換対象を配列に入れたうえで、
その中を変換して、一括書き戻し。これでも、そこそこの処理効率になりますが。

・ツリー全体表示


	【78527】Re:複数の文字列を置換したい

β - 16/10/29(土) 14:25 -


	引用なし

	パスワード

▼naoko さん：

>また、関数かませるとすっごく重くなるのでダメですね。

いえいえ、提案しているのは、最終的には式は残らず、かつ
【すごく軽い】処理方式です。

ただ、アップされたコード、Ｂ列処理ですけど、コメント内に

>置換されては困る列もあるので、一気には無理だとわかりました。

とあるので、対象列は、複数列なんだと思われます。
まぁ、それならそれで、その列に対してループ処理をかければいいのですが、
以下のコードは　Ｂ列のみ対象。　ためしにデータをマッチするもの中心に
３０００件で動かしますと、私の環境で 0.05秒ぐらいの処理ですね。

条件として List というシートに置き換え表を準備しておきます。
1行目から A列が　

クリニック
ケアミックス病院
回復期病院

等

B列に

8
7
4

等

（A列の値昇順にしてください）

作業列を使っています。コードでは C列にしていますが、どの列でもＯＫです。

Sub Sample()
　　Dim t As Double
　　t = Timer
　　
　　Application.ScreenUpdating = False
　　
　　With Sheets("Sheet1")
　　　　With .Range("B1", .Range("B" & Rows.Count).End(xlUp)).Offset(, 1)
　　　　　　.Formula = "=IFERROR(IF(INDEX(List!A:A,MATCH(B1,List!A:A))=B1,VLOOKUP(B1,List!A:B,2),B1),B1)"
　　　　　　.Offset(, -1).Value = .Value
　　　　　　.ClearContents
　　　　End With
　　End With

　　Application.ScreenUpdating = True
　　
　　MsgBox Timer - t
　　
End Sub

・ツリー全体表示


	【78526】Re:複数の文字列を置換したい

マナ - 16/10/29(土) 12:37 -


	引用なし

	パスワード

▼naoko さん：

>高度すぎてかけないです。。。（爆）

高度というより、どんな操作か理解できていないのでは？

>また、関数かませるとすっごく重くなるのでダメですね。

そんなことない気がします。

>他の会社へ渡すファイルとなるので・・・

最後は、値貼り付けで数式は残りません。

>地道にWith～で列ごとに書いていくことにしました！

マクロ不要で、手作業で十分な作業かもしれません。
少なくとも、コード書いている時間と比較にならないでしょう。

・ツリー全体表示


	【78525】Re:複数の文字列を置換したい

マナ - 16/10/29(土) 11:42 -


	引用なし

	パスワード

▼naoko さん：

こっちのほうが、わかりやすかったかも。

Option Explicit

Sub 連続置換()
　　Dim 検索範囲 As Range
　　Dim 最修行 As Long
　　Dim n As Long

　　Set 検索範囲 = Worksheets("Sheet2").Columns("B")
　　
　　With Worksheets("Sheet1")
　　　　最修行 = .Range("A" & Rows.Count).End(xluo).Row
　　
　　　　For n = 2 To 最修行
　　　　　　検索範囲.Replace _
　　　　　　　　　　What:=.Cells(n, 2).Value, _
　　　　　　　　　　Replacement:=.Cells(n, 1).Value, _
　　　　　　　　　　LookAt:=xlWhole, _
　　　　　　　　　　MatchByte:=False
　　　　Next
　　　　
　　End With

End Sub

・ツリー全体表示


	【78524】Re:複数の文字列を置換したい

マナ - 16/10/29(土) 10:44 -


	引用なし

	パスワード

▼naoko さん：

170行はさすがに大変でしょう
例えば、こんな感じでできるはずです。

Option Explicit

Sub 連続置換()
　　Dim 対照表
　　Dim 検索範囲 As Range
　　Dim n As Long

　　対照表 = Worksheets("Sheet1").Range("A!").CurrentRegion.Value
　　
　　Set 検索範囲 = Worksheets("Sheet2").Columns("B")

　　For n = 2 To UBound(対照表)
　　　　検索範囲.Replace What:=対照表(n, 2), Replacement:=対照表(n, 1), _
　　　　　　LookAt:=xlWhole, MatchByte:=False
　　Next

End Sub

・ツリー全体表示


	【78523】Re:複数の文字列を置換したい

naoko - 16/10/28(金) 14:58 -


	引用なし

	パスワード

βさん：

有難うございます。
高度すぎてかけないです。。。（爆）
また、関数かませるとすっごく重くなるのでダメですね。
他の会社へ渡すファイルとなるので・・・

地道にWith～で列ごとに書いていくことにしました！
置換されては困る列もあるので、一気には無理だとわかりました。

ご回答、有難うございました。

・ツリー全体表示


	【78522】Re:複数の文字列を置換したい

β - 16/10/28(金) 11:34 -


	引用なし

	パスワード

▼naoko さん：

↑で

>処理速度の観点からいえば、これが最も秀逸な結果となります。

こう書きましたが Replace にこだわらなければ、

・提案した変換表の文字列と数値をいれかえて　文字列昇順で並び替えをしておき
・それを変換表として、変換対象の列（B列？）とは別の列に、一挙に数式を埋め込み
　埋め込んだ後、それを値変換で、もとの列を書き換える。

この方式が最速だと思います。

コードも３～４行ですね。

・ツリー全体表示


	【78521】Re:複数の文字列を置換したい

β - 16/10/28(金) 11:20 -


	引用なし

	パスワード

▼naoko さん：

>と永遠と書こうかと思ったのですが

処理速度の観点からいえば、これが最も秀逸な結果となります。

ただ、コードが見づらくなりますし、保守性の観点で難ありですかね？

アップされたイメージを変換表として、別シートに作っておく。
通常は、このシートは非表示でいいのですが、この　変換表を参照しながら
Replace をループさせるという記述をすることで、コードはすっきりしますね。

・ツリー全体表示


	【78520】複数の文字列を置換したい

naoko - 16/10/28(金) 11:03 -


	引用なし

	パスワード

お世話になります。

置換後数値・置換したい文字列
1　　　　男性
2　　　　女性
1　　　　看護学生
2　　　　看護師
3　　　　准看護師
1　　　　総合病院
2　　　　急性期病院
3　　　　大学病院
4　　　　回復期病院
5　　　　療養型病院
6　　　　精神科病院
7　　　　ケアミックス病院
8　　　　クリニック
9　　　　有床クリニック

このように、複数の文字列を数値に変換したいのですが
通常だと
Columns("B:B").Replace What:="男性", Replacement:="1"
Columns("B:B").Replace What:="看護学生", Replacement:="1"
・
・
と永遠と書こうかと思ったのですが、170の文字列（単語）があり
文字列を買いてくのは仕方ないのですが、置換後の文字が数値でだぶることもあるので
これを簡素に書く書き方ってありますでしょうか？

・ツリー全体表示


	【78519】Re:ユーザーフォーム上の画像保存方法

ゆうじん - 16/10/26(水) 11:28 -


	引用なし

	パスワード

▼β さん：
Frameを使用して、目的の画像を保存することができました。
βさん！本当にありがとうございました！！

以下のサイトを参考にしました。
ht tps://support.microsoft.com/ja-jp/kb/161299
キャプチャの対象をFrameのハンドルにすることで解決できました。

Public Function CaptureFrame() As IPictureDisp
　　'　Get a handle to the Frame1.
　　Dim hWndScreen As Long
　　WindowFromAccessibleObject Frame1, hWndScreen
　　
　　Dim cxScreen As Long, cyScreen As Long
　　cxScreen = Frame1.Width
　　cyScreen = Frame1.Height
　　
　　' Call CaptureWindow to capture the entire frame give the handle
　　' and return the resulting Picture object.
　　Set CaptureFrame = CaptureWindow(hWndScreen, False, 0, 0, cxScreen, cyScreen)
End Function

・ツリー全体表示


	【78518】Re:ユーザーフォーム上の画像保存方法

ゆうじん - 16/10/26(水) 8:33 -


	引用なし

	パスワード

▼β さん：

やはり難しいですか・・・

一度、Frameを使ってみます。
ご回答ありがとうございました。

・ツリー全体表示


	【78517】Re:ユーザーフォーム上の画像保存方法

β - 16/10/25(火) 20:59 -


	引用なし

	パスワード

▼ゆうじんさん：

どうなんでしょうね。

Imageコントロールでは難しいかもしれません。
かといって、そのあたり、素人ですので詳しくないのですが
Frameコントロールであれば、コンテナとして、その上に配置した　TextBox等も
内包します。

Frameのハンドルは

Private Declare Function WindowFromAccessibleObject Lib "oleacc" ( _
　　　ByVal pacc As Object, _
　　　ByRef phwnd As Long) As Long

を宣言しておいて

　　WindowFromAccessibleObject Frame1, hwnd

等で、変数 hwnd に取得できます。

このハンドルからFrameウィンドウを取得して、そのウィンドウの画面キャプチャを行えば
なにかしら、元画像と、その上にある TextBox が含まれたイメージを取得できると思います。

ただ、申し上げたように、そのあたり詳しくないので。

「vba api windowのキャプチャー」あたりで検索すると参考ページもでてくるとは
思いますが。

これ以上のお手伝いは、私には無理なので、上級者さんの回答をお待ちください。

・ツリー全体表示


	【78516】Re:ユーザーフォーム上の画像保存方法

ゆうじん - 16/10/25(火) 20:10 -


	引用なし

	パスワード

▼β さん：

>何を画像として保存したいのでしょう？
>ユーザーフォーム全体ですか？

チェックボックスと画像が重なって写っているものを画像として保存したいです。
ユーザーフォーム全体ではなく、画像の箇所のみが欲しいです。

>はい。これはImage1の中の画像を名前を付けて保存しているコードですが

だから、チェックボックスが写っていない画像だったのですね。

説明が下手で申し訳ありません。

・ツリー全体表示


	【78515】Re:ユーザーフォーム上の画像保存方法

β - 16/10/25(火) 19:08 -


	引用なし

	パスワード

▼ゆうじんさん：

>以下の方法を試してみましたが、画像のみが取得されました。

はい。これはImage1の中の画像を名前を付けて保存しているコードですが
それでは

>イメージ的には、画像のハードコピーをとるような感じです。

という目的に合わないのですか？

何を画像として保存したいのでしょう？
ユーザーフォーム全体ですか？

・ツリー全体表示


	【78514】ユーザーフォーム上の画像保存方法

ゆうじん - 16/10/25(火) 18:25 -


	引用なし

	パスワード

お世話になっております。

ユーザーフォームにImageコントロールを配置し、画像を表示させています。
その画像の上にテキストボックスを重ねて配置しております。
この状態をJPEG形式で保存したいのですが、どうすれば実現できますでしょうか。
イメージ的には、画像のハードコピーをとるような感じです。

以下の方法を試してみましたが、画像のみが取得されました。
SavePicture UserForm1.image1.Picture, "C:\hoge.jpg"

よろしくお願いいたします。

・ツリー全体表示


	【78513】Re:「・」か改行などで区切られたセルを...

yk - 16/10/24(月) 18:23 -


	引用なし

	パスワード

β様、ありがとうございます！
書いていただいたコードで、まさにやりたかったことが完璧に再現できました！

今まで手作業で時間がかかり、VBAはまだ一部だけ調べて使ってみたりマクロの記録から少し変えたり程度しか分からなかったので、完璧に書いていただけて本当に助かりました。
感謝いたします。ありがとうございました。

・ツリー全体表示


	【78512】Re:「・」か改行などで区切られたセルを...

β - 16/10/24(月) 16:58 -


	引用なし

	パスワード

▼yk さん：

★印、実際のシート名に変更願います。

Sub Sample()
　　Dim dic As Object
　　Dim c As Range
　　Dim w1 As Variant
　　Dim w2 As Variant
　　Dim d1 As Variant
　　Dim d2 As Variant
　　
　　Set dic = CreateObject("Scripting.Dictionary")
　　
　　With Sheets("Sheet1")　 '★入力シート
　　　　For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
　　　　　　w1 = Split(c.Offset(, 1).Value, "・")
　　　　　　w2 = Split(c.Offset(, 2).Value, "・")
　　　　　　If UBound(w1) >= 0 Or UBound(w2) >= 0 Then　'どちらかあれば
　　　　　　　　If UBound(w1) < 0 Then w1 = Array(Empty)
　　　　　　　　If UBound(w2) < 0 Then w2 = Array(Empty)
　　　　　　　　For Each d1 In w1
　　　　　　　　　　For Each d2 In w2
　　　　　　　　　　　　dic(dic.Count) = Array(c.Value, d1, d2)
　　　　　　　　　　Next
　　　　　　　　Next
　　　　　　End If
　　　　Next
　　End With
　　
　　With Sheets("Sheet2")　 '★別シート
　　　　.UsedRange.Offset(1).ClearContents　'タイトル行以外クリア
　　　　.Range("A2").Resize(dic.Count, 3).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))
　　　　On Error Resume Next
　　　　.Range("A2", .Range("A" & Rows.Count).End(xlUp)).Offset(, 1).SpecialCells(xlCellTypeBlanks).Delete xlToLeft
　　　　On Error GoTo 0
　　　　.Select
　　End With
　　
End Sub

・ツリー全体表示


	【78511】Re:「・」か改行などで区切られたセルを...

yk - 16/10/24(月) 16:02 -


	引用なし

	パスワード

ありがとうございます。行ごと（１品番ごと）に入力例AだったりBだったりの混在ではなく、全て入力例Aで入力しています。入力例Aが、セルA列～C列を使っているとしたら、入力例Bは同じシートの同じ行でセルE列以降に数式を使ってセル内改行のBの状態にして列のテキスト保存などを試した入力例でしたが、ややこしいので入力例Bはないものとして無視して構いません。入力例Aの１品番で１行の状態から、１品番が複数行になる完成例にする方法がございましたらお願いします。【入力】　　　色　　　　　　サイズ（入力シート） XXX-001　　｜　黒・白・茶｜　S・M・L XXX-002　　｜　　　　　　｜　M・L XXX-003　　｜　　　　　　｜　 XXX-004　　｜　赤・緑　　｜ ↓ 【完成】　選択１　選択２　（別のシート） XXX-001　｜黒｜　S XXX-001　｜黒｜　M XXX-001　｜黒｜　L XXX-001　｜白｜　S XXX-001　｜白｜　M XXX-001　｜白｜　L XXX-001　｜茶｜　S XXX-001　｜茶｜　M XXX-001　｜茶｜　L XXX-002　｜M ｜ XXX-002　｜L ｜ XXX-004　｜赤｜ XXX-004　｜緑｜ ※色がなくサイズだけのXXX-002は選択１の列にサイズ内容が入る ※色もサイズもないXXX-003は載らないこのような説明で分かりますでしょうか？説明が下手ですみません。入力の仕方が悪く完成形にするのが難しい場合は、１商品１行でしたらある程度変更も可能です。（カラー列・サイズ列にすると空欄が出る商品もあるので、それが支障になる場合は、元からカラーの列にサイズ内容を入れる、など）宜しくお願いします。

・ツリー全体表示


	【78510】Re:「・」か改行などで区切られたセルを...

β - 16/10/24(月) 13:03 -


	引用なし

	パスワード

▼yk さん：

Ａ形式であれＢ形式であれ、最終形に変換するのはいかようにもできます。
ただし、１つのシートに、行ごとにＡ形式だ、Ｂ形式だと混在しているとすれば
その行が、どちらの形式なのかを判定しなければいけませんよね。

その判定基準は？
どこの列のどんな状態を見て、それがこうだったらＡ形式、それがこうだったらＢ形式だというルールを
言葉で提示いただけますか？

・ツリー全体表示


	【78509】Re:「・」か改行などで区切られたセルを...

yk - 16/10/24(月) 10:32 -


	引用なし

	パスワード

分かりづらくてすみません。
現在は、元の入力形式Aは列アルファベット前半に直接情報入力、
B形式は列アルファベット後半にA形式を数式で表示変更したもので
１つのシートに両方入って試行錯誤中です。

どちらかの形式、または他の形式に変えても、「１品番１行」に入れた入力情報から、
別のシートに１品番複数行の「完成形」を作れたらと思っています。

何かアイデアございましたら宜しくお願いします。

・ツリー全体表示


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

197 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free