エクセルファイルシートをセミコロン区切りのテキストファイルに変換して出力したいです。
エクセル2002では以下のVBAで書いたマクロがちゃんと動いてTABをセミコロンに置換できますが、エクセル2003では置換ができなくてデータとデータの間にTABまま出力されます。
Public Sub ExportWorksheetWithCustomDelimiter( _
ByVal SourceWorksheet As Variant, _
ByVal FilePath As String, _
ByVal Delimiter As String)
' Exports the source worksheet as a text file with a custom field delimiter.
' ExportWorksheetWithCustomDelimiter(SourceWorksheet, FilePath, Delimiter)
' SourceWorksheet - The name of or a reference to a worksheet.
' FilePath - The full path to the export file.
' Delimiter - One or more characters to use as the field delimiter.
Dim DisplayAlerts As Boolean
Dim FileNumber As Long
Dim FileData As String
If VarType(SourceWorksheet) = vbString Then SourceWorksheet = ActiveWorkbook.Sheets(SourceWorksheet).Name
' Create copy of source worksheet in new workbook
Sheet1.Copy
' Save copy as tab delimited text file and close
DisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=FilePath, FileFormat:=xlText
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = DisplayAlerts
' Read file into string variable and delete file
FileNumber = FreeFile
'Open FilePath For Binary Access Read Write As FileNumber
Open FilePath & ".txt" For Binary Access Read Write As FileNumber
FileData = StrConv(InputB(LOF(FileNumber), FileNumber), vbUnicode)
Close FileNumber
Kill FilePath & ".txt"
' Replace all tabs with special character
FileData = Replace(FileData, Chr(9), Delimiter)
' Right modified text back out to same file
Open FilePath For Binary Access Read Write As FileNumber
Put FileNumber, , FileData
Close FileNumber
End Sub
上のマクロの実行後の結果は次と同じです。
エクセル2002からマクロの実行結果：AAA;BBB;CCC;DDD;EEE;FFF
エクセル2003からマクロの実行結果：AAA BBB CCC DDD EEE FFF
解決方法を教えてください。
ぜひよろしくお願いします。
ありがとうございます。
エクセルファイルシートをセミコロン区切りのテキストファイルに変換して出力したいです。
エクセル2002では以下のVBAで書いたマクロがちゃんと動いてTABをセミコロンに置換できますが、エクセル2003では置換ができなくてデータとデータの間にTABまま出力されます。
Public Sub ExportWorksheetWithCustomDelimiter( _
ByVal SourceWorksheet As Variant, _
ByVal FilePath As String, _
ByVal Delimiter As String)
' Exports the source worksheet as a text file with a custom field delimiter.
' ExportWorksheetWithCustomDelimiter(SourceWorksheet, FilePath, Delimiter)
' SourceWorksheet - The name of or a reference to a worksheet.
' FilePath - The full path to the export file.
' Delimiter - One or more characters to use as the field delimiter.
Dim DisplayAlerts As Boolean
Dim FileNumber As Long
Dim FileData As String
If VarType(SourceWorksheet) = vbString Then SourceWorksheet = ActiveWorkbook.Sheets(SourceWorksheet).Name
' Create copy of source worksheet in new workbook
Sheet1.Copy
' Save copy as tab delimited text file and close
DisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=FilePath, FileFormat:=xlText
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = DisplayAlerts
' Read file into string variable and delete file
FileNumber = FreeFile
'Open FilePath For Binary Access Read Write As FileNumber
Open FilePath & ".txt" For Binary Access Read Write As FileNumber
FileData = StrConv(InputB(LOF(FileNumber), FileNumber), vbUnicode)
Close FileNumber
Kill FilePath & ".txt"
' Replace all tabs with special character
FileData = Replace(FileData, Chr(9), Delimiter)
' Right modified text back out to same file
Open FilePath For Binary Access Read Write As FileNumber
Put FileNumber, , FileData
Close FileNumber
End Sub
上のマクロの実行後の結果は次と同じです。
エクセル2002からマクロの実行結果：AAA;BBB;CCC;DDD;EEE;FFF
エクセル2003からマクロの実行結果：AAA BBB CCC DDD EEE FFF
解決方法を教えてください。
ぜひよろしくお願いします。
ありがとうございます。
病院を登録するフォームをつくっています。
名前を入れて登録。その後、入力画面がnullになる。
というのはできたのですが、未入力の場合
（登録した後、クリックしたときに）
フィールドに必要なプロパティが True に設定されているため～～
と出てしまいます。
そのエラーメッセージを「"入力してください"」
のメッセージＢＯＸに変えたくて上記のようにしたのですが、
変わりません。どこがおかしいのでしょうか。
どなたか、分かる方ご指導くださいませ。
Private Sub コマンド0_Click()
Dim db As Database, rst As Recordset
Set db = CurrentDb
Set rst = db.OpenRecordset("T_病院", dbOpenTable, dbAppendOnly)
With rst
.AddNew
![病院名] = Me.病院名
If Me![病院名] = Null Then
MsgBox "入力してください"
GoTo minyuuryoku
End If
.Update
minyuuryoku:
End With
Me.病院名 = Null
With db
End With
rst.Close
db.Close
Set db = Nothing
End Sub
ExcelVBAでシート編集時、元に戻す・やり直し機能を使えなくするにはどういうコーディングをすればよいのでしょうか？
現在、シート表示の初期処理で以下のようなコーディングを入れていますが、機能が使えてしまうようです。
Dim Menuobj As Object
Set Menuobj = Application.CommandBars("Worksheet Menu Bar")
Menuobj.Controls.Item(2).Controls.Item(1).Enabled = True
Menuobj.Controls.Item(2).Controls.Item(2).Enabled = True
どなたか教えてください！
よろしくお願いいたします。
E列の5行目から2000行までの間で
鉄、銅、銀、空白以外の文字が入っていたら
『鉱1_Click』という別のマクロを行うというマクロなのですが、
『銀』に限ってはE列5行目～2000行の間に1つだけあっても
『鉱1_Click』を走らせるようにしたいのですが、
どのように改造すればできると思いますか？
E列5行目～2000行の間に『銀』に限っては２つ以上でないと作動しないという風にしたいのです。
E列5行目～2000行の間に鉄、銅、空白、銀(1つ)の状態では発動しないようにしたいです。
当たり前ですが今現在ですと、銀がなかったり１つでも作動してしまいます。
Private Sub 鉱_Click()
Dim ColumnA
Dim flg As Boolean
flg = False
ColumnA = Columns("E:E")
For i = 5 To 2000
If ColumnA(i, 1) = "鉄" Or ColumnA(i, 1) = "銅" Or ColumnA(i, 1) = "銀" Or ColumnA(i, 1) = "" Then
Else
flg = True
Exit For
End If
Next
If flg Then
鉱1_Click
Else
End If
End Sub
配列の間引きをを教えて下さい。
下記文を書きました
Sub 配列()
Dim u As Integer '左
Dim v As Integer '中
Dim w As Integer '右
Dim x As Integer '左
Dim y As Integer '中
Dim z As Integer '右
Dim row As Integer '行カウンタ
Dim col As Integer '列カウンタ
Dim intSheet As Integer 'シートカウンタ
Dim blnNextPage As Boolean '次シートフラグ
'初期値セット
u = 1
v = 2
w = 3
x = 4
y = 5
z = 5
row = 0
col = 1
intSheet = 1
Do While (1)
'zカウント
z = z + 1
If z > 20 Then
'zが20以上ならy+1
y = y + 1
If y > 19 Then
'yが20以上ならx+1
x = x + 1
If x > 18 Then
'xが20以上ならy+1
w = w + 1
If w > 17 Then
'wが20以上ならx+1
v = v + 1
If v > 16 Then
'wが20以上ならx+1
u = u + 1
'終了条件
If (x = 19 And y = 19 And z = 20) Then Exit Do
'v初期化 = x+1
v = u + 1
End If
'w初期化 = y+1
w = v + 1
End If
'x初期化 = x+1
x = w + 1
End If
'y初期化 = y+1
y = x + 1
End If
'z初期化 = y+1
z = y + 1
End If
If z > 20 Then Exit Sub
'行カウント
row = row + 1
If row > 1000 Then
'1000で次の列か次のページへ
If blnNextPage Then
'行・列カウンタ初期化
col = 1
row = 1
'次のシートへ
intSheet = intSheet + 1
'次のシートが無い場合は追加
If intSheet > Worksheets.Count Then
Sheets.Add After:=Worksheets(Worksheets.Count)
End If
'シートをアクティブに
Worksheets(intSheet).Select
'フラグ消去
blnNextPage = False
Else
'次の列へ
col = col + 6
row = 1
'blnNextPage = True
End If
End If
If col = 6 * 3 + 1 Then
blnNextPage = True
End If
'データ表示
Worksheets(intSheet).Range(Chr(64 + col) & row).Cells = u
Worksheets(intSheet).Range(Chr(64 + col + 1) & row).Cells = v
Worksheets(intSheet).Range(Chr(64 + col + 2) & row).Cells = w
Worksheets(intSheet).Range(Chr(64 + col + 3) & row).Cells = x
Worksheets(intSheet).Range(Chr(64 + col + 4) & row).Cells = y
Worksheets(intSheet).Range(Chr(64 + col + 5) & row).Cells = z
Loop
End Sub
上記文で表示をしますが、
６列目までの間に３列の連数字の時には表示を行わず、次に移る様にしたいのですが、どうすれば良いでしょうか？
1,2,5,6,10,12はOKです
1,2,3,5,6,10又は1,3,4,5,10,11等３連の数字は表示を行わない。
Private Sub Workbook_BeforePrint(Cancel As Boolean)
If ActiveSheet.Name = "Sheet1" Then
If Range("D6").Value = "" Then
Cancel = True
MsgBox ("名前を入力してください")
Range("D6").Select
Exit Sub
End If
Else
If ActiveSheet.Name = "Sheet2" Then
If Range("C11").Value = "" Then
Cancel = True
MsgBox ("受付時間を入力してください")
Range("C11").Select
Exit Sub
End If
Else
Exit Sub
End If
End If
If Worksheets("Sheet1").Range("D5") = "不要" Then GoTo P1
ActiveSheet.Range("A70:Y70").Copy
If Worksheets("Sheet3").Range("A1").Value = "" Then
Worksheets("Sheet3").Range("A1").PasteSpecial Paste:=xlPasteValues
Else
Worksheets("Sheet3").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues
End If
Application.CutCopyMode = False
P1:
ActiveSheet.Range("A1").Select
End Sub
sheet1のD5に「不要」と入っていたら
24～33行目の作業がキャンセルになりますが
sheet2のD5にも「不要」と入っていたら、同じ様にキャンセルできる様に出来ますでしょうか？
ご回答お願いします
お世話になります。
下記のように、配列にランダムな数値を入れて、それを昇順、降順にしたいのですが、この場合の SORT の使い方を教えて欲しいです。
Dim YUI(100) As Integer
YUI(1) =88:YUI(2) =53:YUI(3) =7
～ YUI(98) =13:YUI(99) =2:YUI(100) =94
下記のような並べ替えをしていますが、SORT を使った場合の書き方を教えて下さい。
Dim I1,I4,D7 As Integer
For I1 = 1 To 100 - 1
For I4 = I1 + 1 To 100
If YUI(I1) < YUI(I4) Then
D7 = YUI(I4)
YUI(I4) = YUI(I1)
YUI(I1) = D7
End If
Next I4
Next I1
初めまして。
私はWindowsXP、Excel2003のVBAでシートの保護、またそれの解除のコードを組んだのですが、以下のコードでは「○○○と言う名前で保存します。よろしければこのままOKをクリックしてください」の箇所でキャンセルを選択した時に、シートの保護を行いたいのですが、どのようなコードにすればよいてのでしょうか？
例）
Dim FileName As String
Dim FileExt As String
Dim BkName1 As String
Dim BkName2 As String
Dim BkName3 As String
Dim OldWkbook As Workbook
Dim NewWkbook As Workbook
Const StName1 As String = "適材適所グラフ"
Const StName2 As String = "適材適所回答"
Const StName3 As String = "適性検査III回答"
Const StName4 As String = "適性検査IIIグラフ"
'シートの保護を解除
Worksheets("適性検査III回答").Unprotect
Worksheets("適材適所回答").Unprotect
Application.DisplayAlerts = False
Set OldWkbook = ActiveWorkbook
'
'ファイル名を取得
BkName1 = OldWkbook.Sheets(StName3).Range("L1").Value
BkName2 = OldWkbook.Sheets(StName3).Range("L2").Value
BkName3 = OldWkbook.Sheets(StName3).Range("L3").Value
FileName = BkName1 & Format(".") & BkName2 & Format(".") & BkName3 & ".xls"
'
FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName)
If FileName = "" Then
Exit Sub
Else
If Right(FileName, 4) <> ".xls" Then
MsgBox "ファイル名が異常です。"
Exit Sub
End If
End If
OldWkbook.Sheets(Array(StName1, StName2, StName3, StName4)).Copy
Set NewWkbook = ActiveWorkbook
'ボタンを削除
For wIx = NewWkbook.Sheets(1).Shapes.Count To 1 Step -1
If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除
NewWkbook.Sheets(1).Shapes(wIx).Delete
End If
Next
NewWkbook.Sheets(1).Name = StName1
'コピー先シートの保護
Sheets(1).Protect
Sheets(2).Protect
Sheets(3).Protect
Sheets(4).Protect
FileName = "C:\採点結果\" & FileName
If Dir(FileName) <> "" Then
'##ファイルが既に存在する
If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then
NewWkbook.Close savechanges:=False
'##保存せずに終了
Exit Sub
'##指定ファイル置き換え保存
End If
NewWkbook.SaveAs FileName:=FileName
Else
'##ファイルを新規保存
NewWkbook.SaveAs FileName:=FileName
End If
NewWkbook.Close savechanges:=False
Application.DisplayAlerts = True
'シートの保護
Worksheets("適性検査III回答").Protect
Worksheets("適材適所回答").Protect
End Sub
