Excel VBA質問箱 IV

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

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


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

273 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【76979】Re:VBAでシートを作成

β - 15/4/23(木) 20:23 -


	引用なし

	パスワード

▼rinrin さん：

こんばんは

コードそのものはシートやセルのSelectは、意味がないのでなくしたらいいなぁとか
GoTO はやめようよとか、その他もろもろ、思うところはありますが、それはさておき。

>現状では全く意図していないところに新しく作成したシートが出来ちゃいます。。。。

　　ActiveWorkbook.SaveAs _
　　　　FileName:=File購入依頼書 & "xls"
　　　　
SaveAs で指定する際にはファイルのフルパスを使います。
ブック名だけで保存すると、カレントフォルダに保存されます。

ht ps://msdn.microsoft.com/ja-jp/library/office/ff841185.aspx

・ツリー全体表示


	【76978】VBAでシートを作成

rinrin - 15/4/23(木) 18:13 -


	引用なし

	パスワード

Excell2010にコマンドボタンを設定し、”Cmd発注”をクリックすると、必要なメインのExcellシートだけをメイン画面の”実績”フォルダに作成したいです。。。

ではありますが、現状では全く意図していないところに
新しく作成したシートが出来ちゃいます。。。。

どう修正すればよいのか。ご指導よろしくお願いいたします。

Sub Cmd発注()
　　Dim i As Single
　　Dim Iret As Single
　　Dim Size As Single
　　Dim lReturn As Long
　　Dim ActiveFile As String
　　Dim SaveFile, SaveFile1, Hinichi As String
　　Dim OpenFile_Name As String
　　Dim OpenFile_Name_Dir As String
　　
'問い合せﾀﾞｲｱﾛｸﾞの表示をOFFにします
　　Application.DisplayAlerts = False

'依頼No.作成
　　OpenFile_Name = ActiveWorkbook.Path

　　File購入依頼書 = Sheets("治工具").Range("H6").Value
　　Range("H6").Select
　　Selection.UnMerge
　　Range("H6").Select
　　Selection.Copy
　　Range("P6").Select
　　Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
　　　　:=False, Transpose:=False
　　Range("P6").Select

　　ActiveCell.FormulaR1C1 = "=SUBSTITUTE(RC[-8],""/"","""")"
　　File購入依頼書 = ActiveCell.Value
'保存
　　Sheets("治工具").Select
　　Range("A8").Select
　　Sheets("治工具").Copy After:=Sheets(4)
　　ActiveSheet.Name = File購入依頼書
　　ActiveFile = ActiveSheet.Name

　　Sheets(File購入依頼書).Select
　　Sheets(File購入依頼書).Copy
　　
'ﾌｫﾙﾀﾞ名がなければ作成する
　　OpenFile_Name_Dir = OpenFile_Name & "\実績\"　　　　　　　'Openフォルダ名取得
　　
　　If Dir(SaveDir, vbDirectory) = "" Then
　　　　MkDir "実績"
　　　　MkDir OpenFile_Name_Dir
　　End If

　　ActiveWorkbook.SaveAs _
　　　　FileName:=File購入依頼書 & "xls"
　　　　
　　Hinichi = File購入依頼書
　　Size = Len(File購入依頼書)　　　　　　　　　　　　　 'フルパス名長

　　SaveFile = OpenFile_Name_Dir & File購入依頼書 & ".xlsx"　　'保存ファイル名創生

　　Workbooks(1).Activate
　　　　Sheets(File購入依頼書).Select
　　　　Sheets(File購入依頼書).Delete

　　Workbooks(2).Activate

　　Size = Len(SaveFile)　　　　　　　　　　　　　　　　'フルパス名長
　　For i = Size To 1 Step -1
　　　　If Mid(SaveFile, i, 1) = "\" Then
　　　　　　SaveFile1 = Right(SaveFile, Size - i)　　　 'Openフルパス名取得
　　　　　　Exit For
　　　　End If
　　Next i
　　
　　Range("A8").Select
Retry:
　　Iret = MsgBox("『" & SaveFile & "』　で保存しますが、宜しいですか？" & vbCrLf + vbLf & "フォルダーを変更する場合は『いいえ』を選択して下さい。", vbQuestion + vbYesNo)
　　If Iret = vbYes Then
　　　　Exit Sub
　　　　Else

　　　　　　lReturn = Application.Dialogs(xlDialogSaveAs).Show(arg1:=SaveFile1, arg2:=18)
'保存画面　document_text、type_num、prot_pwd、backup、write_res_pwd、read_only_rec
　　　　　　If lReturn = False Then　　　　　　　　　　 'CanselならばRetryに戻る
　　　　　　　　GoTo Retry
　　　　　　End If
　　End If

　　GoTo FIN
CHK:
　　If Err.Number = 76 Then　　　　'Pathが存在しない場合にフォルダー作成
　　　　　　MkDir OpenFile_Name & File購入依頼書
　　　　Else
　　　　　　MsgBox (Err.Description)
　　End If
　　Resume Next

'問い合せﾀﾞｲｱﾛｸﾞの表示をONに戻します
　　Application.DisplayAlerts = True
'発注Skip:
FIN:
End Sub

・ツリー全体表示


	【76977】Re:ハイパーリンクのファイルの更新日時...

ko - 15/4/23(木) 16:44 -


	引用なし

	パスワード

おそらく、自己解決しました。

LANでつないだ別のPCから操作した場合に、質問の状態になるようで、
ファイルが保存されているPCで操作すると、正常にデータが更新されていました。

あまり意識していなかったので気づきませんでした。

ありがとうございました。

・ツリー全体表示


	【76976】Re:ハイパーリンクのファイルの更新日時...

ko - 15/4/23(木) 16:39 -


	引用なし

	パスワード

自己解決しました。

あまり重要でないと思って、書いていませんでしたが、
LANでつないだ別のPCから操作した場合に、質問の状態になるようで、
ファイルが保存されているPCで操作すると、正常にデータが更新されていました。

セキュリティの関係でしょうか？？
そのあたり、あまり意識していなかったので気づきませんでした。

ありがとうございました。

・ツリー全体表示


	【76975】Re:ハイパーリンクのファイルの更新日時...

ko - 15/4/23(木) 14:42 -


	引用なし

	パスワード

追記です。

新しく作成したファイルのハイパーリンクを追加したのですが、
そもそも、更新日時の取得をしてくれません（泣
元ファイルのプロパティの更新日時は正常です。

・ツリー全体表示


	【76974】Re:ハイパーリンクのファイルの更新日時...

ko - 15/4/23(木) 13:37 -


	引用なし

	パスワード

独覚さん

ファイルのプロパティ自体は、正確な日時になっています。

あと、日時取得だけで　End　Subにしておらず、
続けて並べ替えするようにしています。

　　ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
　　ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C1") _
　　　　, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
　　Dim LastRow As Long
　　LastRow = Cells(Rows.Count, 1).End(xlUp).Row
　　
　　With ActiveWorkbook.Worksheets("Sheet1").Sort
　　　　.SetRange Range("a1", "c" & LastRow)
　　　　.Header = xlYes
　　　　.MatchCase = False
　　　　.Orientation = xlTopToBottom
　　　　.SortMethod = xlPinYin
　　　　.Apply
　　End With
　　
　　
End Sub

・ツリー全体表示


	【76973】Re:ハイパーリンクのファイルの更新日時...

独覚 - 15/4/23(木) 13:28 -


	引用なし

	パスワード

▼ko さん：
あいにくWindowsXPの環境がないため回答が難しいのですが、そのファイルの

プロパティを直接見たときの更新日付はどうなっていますか？

・ツリー全体表示


	【76972】Re:ハイパーリンクのファイルの更新日時...

ko - 15/4/23(木) 13:19 -


	引用なし

	パスワード

βさん、独覚さん、ありがとうございます。

ファイルはローカルにあるものだけですが、
ＯＳがWindowsXPです。やはりOSの問題なのでしょうか・・・

・ツリー全体表示


	【76971】Re:ハイパーリンクのファイルの更新日時...

独覚 - 15/4/23(木) 13:07 -


	引用なし

	パスワード

▼ko さん：
何かほかに特記事項はないですか？

私のほうでもWindows7+Excel2007で実行してみましたがローカルファイル、
サーバ（Windowsサーバ2003）上の共有フォルダ上のファイルどちらとも
当日内の更新日時が反映されています。

koさんのところで、OSのバージョン、ファイルがローカルの場合、サーバ上の場合
どちらでも同じ状況なのか？
また、サーバ上のファイルの場合、サーバのOSはなんでしょうか？

・ツリー全体表示


	【76970】Re:ハイパーリンクのファイルの更新日時...

β - 15/4/23(木) 12:12 -


	引用なし

	パスワード

▼ko さん：

追伸で。

1週間前が最終更新日のブックをハイパーリンクで設定して
そのブックを更新して最終更新日を今日にして実行。

やはり、正しく、今日の日時になります。

・ツリー全体表示


	【76969】Re:ハイパーリンクのファイルの更新日時...

β - 15/4/23(木) 12:07 -


	引用なし

	パスワード

▼ko さん：

こんにちは

不思議ですねぇ。
こちら、2007 の環境がなく、そのバージョンでの確認はできないのですが
2013 で　12:00 に更新、そのあと、12:05 に更新。
こうした後、アップされたコードを実行しますと、12:05 になりますが？

・ツリー全体表示


	【76968】ハイパーリンクのファイルの更新日時取得

ko

- 15/4/23(木) 11:23 -


	引用なし

	パスワード

すみません、何が問題かわからないので、ご教示願います。

ハイパーリンクのファイルの更新日時を取得したいのですが、
マクロを実行しても、実際に更新された日時に変わりません。
おそらく、当日の更新に対応できていないように思われます。

※例えば、23日10:00に実行したとき、23日9:00に更新されたファイルがあっても、それは反映されず、
22日時点で更新されたものだけが反映されている状況です。　

Excel2007です。

Sub Auto_Open()
　　Dim rng As Range
　　Dim FileName As String
　　Dim fso As New FileSystemObject

　　ChDir ThisWorkbook.Path
　　For Each rng In ActiveSheet.UsedRange
　　　　If rng.Hyperlinks.Count > 0 Then
　　　　　　FileName = fso.GetAbsolutePathName(rng.Hyperlinks(1).Address)
　　　　　　If fso.FileExists(FileName) Then
　　　　　　　　rng.Offset(0, 1) = fso.GetFile(FileName).DateLastModified
　　　　　　End If
　　　　End If
　　Next
　　
　
よろしくおねがいします。

・ツリー全体表示


	【76967】Re:VBAで文字列中に「スペース」を挿入し...

β - 15/4/23(木) 8:27 -


	引用なし

	パスワード

▼γ さん：

もし、お目に留まればご教示をお願いします。

パターンで、(\w|[^\x01-\x7E\xA1-\xDF\s]+)　ここまでは理解できました。
そのあとの、(?!\s)　の役割が、
( ) でくくっておられますので、これがでてきてもリプレースの対象にはしないで残す。
こういうことなのかなぁと思っていますがそれで、あっていますか？
それと、この、(?!\s) は、その前の [^\x01-\x7E\xA1-\xDF\s]+)に連続したパターンで
\w　ないしは　[^\x01-\x7E\xA1-\xDF\s]+)(?!\s)
と考えていいのでしょうか？

で、その中の ? ですが、これは、その前の + に付け加えられている、いわゆる
最短一致のための ? でしょうか。
それなら、 ? は、その前の ( ) 内で +?) でおわらせるように思えますので
きっと解釈が間違っているんだろうなとも思っています。

それと　! ですが、これはメタ文字でしょうか？
手元のメモでは、! は　ＶＢＡの正規表現メタ文字とは記述されていないのですが
メタ文字だとすれば、全角文字列の最後にスペースがあるものは対象にしないという意味でよろしいでしょうか？
？

・ツリー全体表示


	【76966】Re:VBAで文字列中に「スペース」を挿入し...

γ - 15/4/22(水) 23:25 -


	引用なし

	パスワード

▼β さん：
ありがとうございます。

>半角、全角混在のA1の文字列を分割して
ということなら、こんな書き方もあるかと思います。

Sub test()
　　Dim reg As Object
　　Dim s As String
　　Dim w As Variant

　　s = "AB C全角文字列D 全角文字列EF"
　　Set reg = CreateObject("VBScript.RegExp")
　　reg.Global = True
　　reg.Pattern = "(\w|[^\x01-\x7E\xA1-\xDF\s]+)(?!\s)"

　　s = reg.Replace(s, "$1 ")
　　Debug.Print s
　　' =>　　 "A B C 全角文字列 D 全角文字列 E F "

　　s = WorksheetFunction.Trim(s)
　　w = Split(s)

　　Range("A2").Resize(, UBound(w) + 1).Value = w
End Sub

・ツリー全体表示


	【76965】Re:VBAで文字列中に「スペース」を挿入し...

β - 15/4/22(水) 8:21 -


	引用なし

	パスワード

▼γ さん：

なるほど！
勉強になります。

γさんのパターンを拝借して、半角、全角混在のA1の文字列を分割して
A2以降の２行目に半角は１文字１セル、全角は、連続文字１セルに書きこんでみました。

Sub test()
　　Dim reg As Object
　　Dim s As String
　　Dim w As Variant
　　
　　Rows(2).ClearContents
　　s = Range("A1").Value

　　Set reg = CreateObject("VBScript.RegExp")
　　
　　reg.Global = True
　　reg.Pattern = "([\x01-\x7E\xA1-\xDF]{1})|([^\x01-\x7E\xA1-\xDF]+)"
　　s = reg.Replace(s, "$1 $2 ")
　　s = WorksheetFunction.Trim(s)
　　w = Split(s)

　　Range("A2").Resize(, UBound(w) + 1).Value = w
　　
End Sub

・ツリー全体表示


	【76964】Re:VBAで文字列中に「スペース」を挿入し...

γ - 15/4/21(火) 22:51 -


	引用なし

	パスワード

正規表現を使った例です。

# 正規表現をご存じなければ、うっちゃっておいて、
# 他のかたの回答を参考にしてください。

Sub test()
　　Dim reg As Object
　　Dim s As String

　　s = "A B C 全角文字列D 全角文字列E F"

　　Set reg = CreateObject("VBScript.RegExp")
　　reg.Pattern = "([^\x01-\x7E\xA1-\xDF]+)(\S)"
　　reg.Global = True
　　s = reg.Replace(s, "$1 $2")
　　
　　Debug.Print s ' 出力=> "A B C 全角文字列 D 全角文字列 E F"

End Sub

・ツリー全体表示


	【76963】Re:VBAで文字列中に「スペース」を挿入し...

初投稿 - 15/4/21(火) 22:11 -


	引用なし

	パスワード

▼kanabun さん：

お礼が遅くなって申し訳ございません
なぜか書き込みができなくて…

いくつかいただいた方法の中から作成中のコードと組み合わせて
使いやすいほうを参考にさせていただきます。

ありがとうございました

>＞「半角スペース」を区切りとしてそれぞれの文字列をセルに代入したい
>
>シートのセルに代入したんでしたね。
>
>＞　　MsgBox Join(v, " ")
>
>を以下に変更です。
>
>　　v = Split(Join(v))
>　　Range("B1").Resize(, UBound(v) + 1).Value = v

・ツリー全体表示


	【76962】Re:VBAで文字列中に「スペース」を挿入し...

初投稿 - 15/4/21(火) 22:09 -


	引用なし

	パスワード

▼β さん：

お礼が遅くなって申し訳ございません
なぜか書き込みができなくて…

いくつかいただいた方法の中から作成中のコードと組み合わせて
使いやすいほうを参考にさせていただきます。

ありがとうございました

>▼初投稿さん：
>
>>正規表現を使えば、・・・
>
>正規表現では対応できませんね。撤回。
>
>>サンプルです。 A1 にある文字列を B1以降に分割します。
>
>　　Range("A1").Parse p, Range("B1")
>
>これを
>
>　　Range("A1").Parse p, Range("A1")
>
>にすれば、分割イメージは A1 からセットされます。

・ツリー全体表示


	【76961】Re:VBAで文字列中に「スペース」を挿入し...

β - 15/4/20(月) 22:00 -


	引用なし

	パスワード

▼初投稿さん：

ループはなくせないんですが、Parseメソッドに与えるパターンを
無理やり（？）正規表現で作成してみました。

Sub Test2()
　　Dim reg As Object
　　Dim s As String
　　Dim w As Variant
　　Dim i As Long
　　
　　s = Range("A1").Value
　　Set reg = CreateObject("VBScript.RegExp")
　　reg.Pattern = "(.{1})"
　　reg.Global = True
　　s = reg.Replace(s, "$1 ")
　　w = Split(s)
　　ReDim Preserve w(LBound(w) To UBound(w) - 1)
　　For i = LBound(w) To UBound(w)
　　　　If LenB(StrConv(w(i), vbFromUnicode)) = 2 Then
　　　　　　w(i) = 2
　　　　Else
　　　　　　w(i) = 1
　　　　End If
　　Next
　　
　　s = Join(w, "")
　　reg.Pattern = "(2+)"
　　s = reg.Replace(s, "[$1]")
　　s = Replace(s, "2", "x")
　　s = Replace(s, "1", "[x]")
　　
　　Range("A1").Parse s, Range("A1")
　　
End Sub

・ツリー全体表示


	【76960】Re:VBAで文字列中に「スペース」を挿入し...

kanabun - 15/4/20(月) 20:18 -


	引用なし

	パスワード

＞「半角スペース」を区切りとしてそれぞれの文字列をセルに代入したいシートのセルに代入したんでしたね。＞　　MsgBox Join(v, " ") を以下に変更です。　　v = Split(Join(v)) 　　Range("B1").Resize(, UBound(v) + 1).Value = v

・ツリー全体表示


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

273 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free