excel VBAを利用し、テンプレートとなるワードファイルの一部分をエクセルデータで
置換を行い、新しいワードファイルとして保存するという処理を作成しています。
[環境]
Windows Vista
Office 2007
差し込み文書ではなく個別にファイルを作りたいという条件があります。
処理としては、
テンプレートを開く→置換を実施→別名で保存→テンプレートを変更せず閉じる
を繰り返し実施しています。
ただ、このやり方ですと最後の閉じる処理を行った際に、
「wordは、動作を停止しました」というエラーメッセージが頻繁に出てしまいます。
出来上がったファイル自体は問題なく読めているんですが。
処理自体に問題があるんでしょうか？
VBA自体初心者であり、他に良い方法などありましたらご教示いただけたら助かります。
#処理内容はだいぶ簡略化しています。
Public Function output_word2()
Dim word As New word.Application
Dim document As word.document
Dim file_name As String
Dim output As String
Dim path As String
Dim row As Integer
Sheets(CALC_SHEET).Select 'データ取得用シート
path = Application.ActiveWorkbook.path
file_name = path & "\xxxxxx.doc" '元の文書
row = 3
Do
If Range("B" & row).Value = "" Then
Exit Do
End If
With word
.Documents.Open Filename:=file_name
Set document = .ActiveDocument
End With
word.Selection.Find.Text = "{置換対象文字}"
word.Selection.Find.Forward = True
word.Selection.Find.Replacement.Text = Range("C" & row).Value
word.Selection.Find.Execute , , , , , , , , , , wdReplaceAll
output = path & "\output\" & Range("C" & row).Value & ".doc"
document.SaveAs Filename:=output '置換後のword文書を別名で保存
document.Close SaveChanges:=False
word.Quit
row = row + 1
Set word = Nothing
Set document = Nothing
Loop
End Function
VB2008改行できません
お願いします。
メロンパン 3個 240円
コロッケパン 2個 …
という風にしたいのですが、
一行目が表示され、2行目の「コロッケパン」を入れた瞬間、
1行目が消え、
コロッケパンのみが表示されます。
なぜでしょうか。
正しいコードと、どのような理屈でそうなるのか頂けると嬉しいです。
Public Class Form1
Dim cm, a As String
Dim kosu, en As Integer
Private Sub ShapeComboBox_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ShapeComboBox.SelectedIndexChanged
cm = ShapeComboBox.Text
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
kosu = TextBox1.Text
Select Case ShapeComboBox.SelectedIndex
Case 0
en = kosu * 120
Case 1
en = kosu * 180
Case 2
en = kosu * 240
End Select
txtKaimono.Text = cm + kosu.ToString(" ##個") + en.ToString(" #,###円") + vbCrLf
End Sub
Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
Application.Exit()
End Sub
End Class
ExcelVBAで、キーボード方向キーを押したら、その方向に塗りつぶしたセルを移動させたいです。
とりあえず、以下のようなマクロを組んだのですが、
方向キーを一度でも押すと、押した方向の彼方へ一瞬で飛んでいってしまいます。
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long 'キー入力のAPI
'一番最初に塗りつぶすセル
set 塗りつぶし = Range("B2,C2")
do
塗りつぶし.Interior.ColorIndex = 3 '赤く塗りつぶし
'左入力したら塗りつぶしセルを左に移動
If GetAsyncKeyState(37) Then
塗りつぶし.Interior.ColorIndex = 0
Set 塗りつぶし = 塗りつぶし.Offset(0, -1)
End If
'右入力したら塗りつぶしセルを右に移動
If GetAsyncKeyState(39) <> 0 Then
塗りつぶし.Interior.ColorIndex = 0
Set 塗りつぶし = 塗りつぶし.Offset(0, 1)
End If
Loop
予想なんですが、一度でもキーを入力したら、
その方向へずっと入力しているようになっている
と思うのですが、どう直して良いか分かりません。
宜しくお願いします。
エクセルVBAでBOOKを開く際の処理
エクセル2000です。
VBAで特定のフォルダー内のBOOKを開き、１枚目のシートSheets(1)のデータを読み込んで別BOOK（マクロを記載したBOOK）にコピペしたら保存せず閉じるコードを下記のように書きました。（かなり簡略化しましたが）
これで作動するのですが、万一、そのフォルダー内のBOOKが開いていても１枚目のシートのデータを読み込み後、閉じられてしまいます。
BOOKが開いていれば、その開いていたBOOKは閉じず、先に進むようにするにはどのように直せばいいでしょうか？
Sub TEST01()
Dim mb As Workbook, wb As Workbook
Dim myfd As String, fnme As String, ans As Byte, i As Long
ans = MsgBox("集計用フォルダーには回収したアンケートファイルとこの集計用ファイルしかないですね？", vbYesNo + vbQuestion, "（￣∇￣) ？ ")
If ans = vbNo Then
MsgBox "それじゃだめです。", vbCritical, "Σ（￣ロ￣lll)"
Exit Sub
End If
Set mb = ThisWorkbook
myfd = mb.Path
fnme = Dir(myfd & "\*.xls")
Do Until fnme = Empty
If fnme <> mb.Name Then
Set wb = Workbooks.Open(myfd & "\" & fnme)
i = i + 1
mb.Sheets(1).Cells(i, 1) = wb.Sheets(1).Range("S10")
wb.Close (False) '保存せずに閉じる
End If
fnme = Dir
Loop
Set mb = Nothing
Set wb = Nothing
MsgBox i
End Sub
Access VBA にて on error goto がたまに機能しないPCがあるます。
具体的には、on error gotoのコーディングを無視して、エラーのポップアップが表示される
何か対応する方法は、ありますか？
環境 ネットーワークにあるmdbをドライブに接続して、Accessを起動しています。
Windows2000(sp4)+Access2000(sp3)
他のPCでは、問題ありません。PCは、イメージをクローンして作成していますので、同一です。
※コーディングイメージ
Private Sub 稼働時間_AfterUpdate()
on error goto ERR_稼働時間
Dim errcnt as integer
errcnt = 0
DoCmd.GotoRecord A_FORM,"時間入力",A_NEXT <----- エラーのポップアップが表示される
if errcnt = 1 Then
DoCmd.GotoRecord A_FORM,"時間入力",A_PREVIOUS
end if
exit sub
ERR_稼働時間:
errcnt = errcnt + 1
resume next
end sub
EXCEL VBAで教えてください。 ユーザーフォームに開始日、終了日を入れ、コマンドボタンを押し、sheet1の開始日から終了日に該当するセルをコピーし、sheet2に貼り付けたいのですが、うまくいきません。
今は、メッセージボックスで範囲指定し、コピー＆ペーストしているのですが、ユーザーフォームで開始日終了日を指定して、コピーしSheet2へ貼り付けたいのです。
--------------------
Sub 届()
Dim myPath As String
Dim myFName As String
Dim ファイル名 As String
Workbooks("処理.xls").Activate
Range("B10:K80").Select
Selection.ClearContents
myPath = ActiveWorkbook.Path
ChDir myPath
myFName = Dir("m.txt")
Dim データ形式 As Variant
Dim 区切りタブ As Variant
ファイル名 = "m.txt"
データ形式 = xlDelimited
区切りタブ = True
Workbooks.OpenText Filename:="m.txt", DataType:=xlDelimited, Tab:=True
Selection.AutoFilter
Selection.AutoFilter Field:=3, Criteria1:="<>"
Columns("C:E").EntireColumn.AutoFit
Range("C2").Sort key1:=Columns("C"), Order1:=xlAscending, Header:= _
xlGuess
Worksheets.Add
Worksheets("m").Select
Dim moto As Range, saki As Range
On Error Resume Next
Set moto = Application.InputBox("どの範囲をコピーしますか？" & Chr(13) & "開始日、終了日を確認してください" & Chr(13) & "A列からE列まで選択してください", Type:=8)
If moto Is Nothing Then Exit Sub
If moto.Parent.Name <> "m" Then
MsgBox "m から選択してください"
Exit Sub
End If
Worksheets("Sheet1").Select
Set saki = Application.InputBox("どこに貼り付けますか？" & Chr(13) & "A4", Type:=8).Cells(1, 1)
If saki Is Nothing Then Exit Sub
If saki.Parent.Name <> "Sheet1" Then
MsgBox "Sheet1 から選択してください"
Exit Sub
End If
On Error GoTo 0
moto.Copy saki
ActiveWorkbook.SaveAs Filename:="届.xls", FileFormat:=xlWorkbookNormal
MsgBox "対象者をコピーしました"
End Sub
------------------
下記でやってみたのですがうまくいきません。
Private Sub CommandButton1_Click()
With Worksheets("sheet1")
開始日 = ">=" & TextBox1.Text
終了日 = "<=" & TextBox2.Text
ActiveSheet.Range("A1:N200").AutoFilter , Field:=3, _
Criteria1:=開始日, Operator:=xlAnd, _
Criteria2:=終了日
Unload UserForm1
End With
End Sub
Windows7, MSWord2007 でマクロを使用しています。以前うまく行っていたのに今日はエラーで止まります。
記入した文字を日本字はMS明朝10.5PT, 半角アルファベットはTimesNewRomanPT12 に統一するマクロです。
[検索する文字列]に指定したパターンマッチングが正しくありません、と表示されます。
他人からいただいたマクロなので自分で直せません。ご援助いただければと存じます。
止まった行： .Execute Replace:=wdReplaceAll
マクロ全文：
Sub SelectedFontChangedMSMincho10_5TimesNewRoman12()
Dim myRng As Range
With ActiveDocument
Set myRng = .Range(Selection.Range.Start, .Range.End)
End With
With myRng.Font
.NameFarEast = "ＭＳ 明朝"
.NameAscii = "Times New Roman"
.NameOther = "Times New Roman"
.Size = 10.5
End With
With myRng.Find
.ClearFormatting
.Text = "[0-9A-Za-z,.\\\!\?""'/$\%\&\#\(\)\=\-\+\<\>]{1,}" '半角スペース～チルダ
.Forward = True
.Wrap = wdFindStop
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.MatchFuzzy = False
With .Replacement
.ClearFormatting
.Text = ""
.Font.Size = 12
End With
.Execute Replace:=wdReplaceAll
End With
End Sub
