IT備忘録: VBA

エクセルで自動印刷

エクセルシートにデータを貼り付けると（シートに変更があると）

自動印刷するVBAを作りました。

----------------

Private Sub Worksheet_Change(ByVal Target As Range)

ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

Application.EnableEvents = False

Cells.Select
Selection.ClearContents
Range("A1").Select

Application.EnableEvents = True

----------------

考えたフローは、
１．印刷をする
２．イベントのチェックを止める
３．データのクリアー
４．イベントのチェックを始める

イベントのチェックを止めておかないと、”データクリアー”時に
イベントが発生してしまい、ループしてしまいます。
Worksheet_Changeを使用するときにはループしないよう、
Application.EnableEvents = False
処理
Application.EnableEvents = True
とするとよいようです。

Posted on May 21, 2008 at 06:10 in Excel, VBA | Permalink | Comments (0) | TrackBack (0)

ExcelとbatでDisk容量チェック

ExcelのVBAとDOSコマンド"dir"と"find"を駆使して、Windows Serverの
Disk空き容量を確認及び記録するシステムを作りました。

--ファイルPath
D:\disk_check.xls このエクセルファイルから実行します。
D:\disk_check.bat 各サーバーの空き容量をdisk.txtへ書き出し
D:\disk.txt 出力ファイル

disk_check.bat
-----
@echo off

set USER-NAME=HogeUser
set PASSWD=hogehoge
set DRIVE=z:
set OUTFILE="D:\disk.txt"

set SERVER1=\\hoge_server01\group
set SERVER2=\\hoge_server02\group
set SERVER3=\\hoge_server03\group

if exist %DRIVE% net use /delete %DRIVE%

net use %DRIVE% %SERVER1% %PASSWD% /user:%USER%
dir %DRIVE% | find "バイトの空き領域" > %OUTFILE%
net use /delete %DRIVE%

net use %DRIVE% %SERVER2% %PASSWD% /user:%USER%
dir %DRIVE% | find "バイトの空き領域" >> %OUTFILE%
net use /delete %DRIVE%

net use %DRIVE% %SERVER3% %PASSWD% /user:%USER%
dir %DRIVE% | find "バイトの空き領域" >> %OUTFILE%
net use /delete %DRIVE%

echo. >> %OUTFILE%
time /t >> %OUTFILE%
date /t >> %OUTFILE%

exit
-----

disk_check.xls
-------------------------------
Private Sub CommandButton1_Click()

Dim myID As Double
myID = Shell("D:\disk_check.bat", vbNormalFocus)

End Sub
-------------------------------
Private Sub CommandButton2_Click()

Worksheets("calc").Activate

Workbooks.OpenText Filename:="D:\disk.txt", Origin:=932, StartRow:=1, _
DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(11, 1), Array(16, 1) _
, Array(33, 1), Array(49, 1)), TrailingMinusNumbers:=True
Windows("disk.txt").Activate
Worksheets("disk").Range("D1:D4").Select
Selection.Copy
Windows("disk_check.xls").Activate
Range("B4").Select
ActiveSheet.Paste
Windows("disk.txt").Activate
Worksheets("disk").Range("A6").Select
Application.CutCopyMode = False
Selection.Copy
Windows("disk_check.xls").Activate
Range("B2").Select
ActiveSheet.Paste
Windows("disk.txt").Activate
Worksheets("disk").Range("A7").Select
Application.CutCopyMode = False
Selection.Copy
Windows("disk_check.xls").Activate
Range("B1").Select
ActiveSheet.Paste
Windows("disk.txt").Activate
ActiveWindow.Close

Windows("disk_check.xls").Activate
Worksheets("Record").Activate

With Worksheets("Record")
      .Range("A65536").End(xlUp).Offset(1, 0).Value = Worksheets("calc").Range("B1")
      .Range("A65536").End(xlUp).Offset(0, 1).Value = Worksheets("calc").Range("B2")
      .Range("A65536").End(xlUp).Offset(0, 2).Value = Worksheets("calc").Range("E4")
      .Range("A65536").End(xlUp).Offset(0, 4).Value = Worksheets("calc").Range("E5")
      .Range("A65536").End(xlUp).Offset(0, 6).Value = Worksheets("calc").Range("E6")
      .Range("A65536").End(xlUp).Offset(0, 8).Value = Worksheets("calc").Range("E7")
End With

Worksheets("calc").Activate

End Sub
-------------------------------

Posted on Mar 28, 2008 at 07:09 in Excel, Script, VBA, 管理ツール | Permalink | Comments (0) | TrackBack (0)

Notes個人アドレス -> CSV

Notes6.5.3で作成した個人アドレス帳を汎用的なCSV形式のファイルへ
取り込むExce VBAを書きました。

------------------
Sub Start_Run()

'配列宣言
'***************************
Dim Values(65000, 2) As String
Dim Count As Integer

'CSVファイルの取り込み
'***************************

'Data削除
'***************************

Sheets("Calc").Select
Cells.Select
Selection.ClearContents
Range("A1").Select

'Data取り込み
'***************************

Workbooks.Open Filename:="D:\Address.csv"
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
      Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
      :=":", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
      TrailingMinusNumbers:=True
Columns("A:B").Select
Selection.Copy
Windows("NotesAddress2CSV.xls").Activate
Range("A1").Select
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Range("B1").Select
ActiveCell.FormulaR1C1 = "=MID(RC[1],3,256)"
Range("B1").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

Windows("Address.csv").Close

'配列への取り込み
'***************************
For i = 1 To Range("A65536").End(xlUp).Row

      For j = 1 To 2
         Values(i, j) = Cells(i, j)
      Next j

Next i

'判断及びAddressシートへ取り込み
'***************************
For i = 1 To Range("A65536").End(xlUp).Row

Select Case Values(i, 1)
      Case "LastName"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(1, 0).Value = Values(i, 2)
         End With

      Case "FirstName"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 1).Value = Values(i, 2)
         End With

      Case "OfficePhoneNumber"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 2).Value = Values(i, 2)
         End With

      Case "OfficeFAXPhoneNumber"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 3).Value = Values(i, 2)
         End With

      Case "CellPhoneNumber"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 4).Value = Values(i, 2)
         End With

      Case "AltFullNameSort_1"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 5).Value = Values(i, 2)
         End With

      Case "PhoneNumber"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 6).Value = Values(i, 2)
         End With

      Case "HomeFAXPhoneNumber"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 7).Value = Values(i, 2)
         End With

      Case "CompanyName"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 8).Value = Values(i, 2)
         End With

      Case "MailAddress"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 9).Value = Values(i, 2)
         End With

      Case "CompanyNameYomi"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 10).Value = Values(i, 2)
         End With

      Case "JobTitle"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 11).Value = Values(i, 2)
         End With

      Case "WebSite"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 12).Value = Values(i, 2)
         End With

      Case "FullName"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 13).Value = Values(i, 2)
         End With

      Case "InternetAddress"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 14).Value = Values(i, 2)
         End With

      Case "$Revisions"
         With ThisWorkbook.Worksheets("Address")
            .Range("B65536").End(xlUp).Offset(0, 15).Value = Values(i, 2)
         End With
End Select

Next i

'番号付け
'***************************
Sheets("Address").Select

Count = Range("K65536").End(xlUp).Row
Count = Count - 1

For i = 1 To Count
Cells(i + 1, 1) = i
Next i

End Sub

----------------------
Sub Clear()

'Sheet "Address" data削除
'***************************
Sheets("Address").Select
Application.Goto Reference:="dat"
Selection.ClearContents
Range("A1").Select

'Sheet "Calc" data削除
'***************************
Sheets("Calc").Select
Cells.Select
Selection.ClearContents
Range("A1").Select
Sheets("HowTo").Select

End Sub
----------------------

Posted on Jan 04, 2008 at 07:27 in VBA | Permalink | Comments (0) | TrackBack (0)

簡単な判別　エクセルVBA

------------------------------
Sub Macro1()

Dim i_End As Integer
Dim i, j As Integer

i_End = Range("D65536").End(xlUp).Row
j = 1

For i = 2 To i_End

      If Cells(i, 2) = Cells(i - 1, 2) Then
         j = j + 1
         Cells(i, 3) = j

      Else
         j = 1
         Cells(i, 3) = j

End If

Next i

End Sub
------------------------------

Posted on May 10, 2007 at 22:45 in VBA | Permalink | Comments (0) | TrackBack (0)

入力フォーム

テンプレートとなるSheetを元に値を入力し、その値をlogとして
残すVBAを組んでみました。

------------------------------------------------------

Private Sub Workbook_Open()

Sheets("START").Activate
Range("G7").Activate

End Sub

------------------------------------------------------

Private Sub CommandButton1_Click()

' *************************
' 初期設定
' *************************
Dim START As Object

Set START = ThisWorkbook.Worksheets("START")

' *************************
' ORGよりシートをコピーする
' *************************
Sheets("ORG").Select
Sheets("ORG").Copy After:=Sheets(3)
Sheets("ORG (2)").Name = "New_User"

' *************************
' 値を挿入
' *************************
Sheets("New_User").Activate

With ThisWorkbook.Worksheets("New_User")
.Range("M5") = START.Range("G8")
.Range("M7") = START.Range("G9")
.Range("C15") = START.Range("G10")
.Range("J20") = START.Range("G8")
.Range("J22") = START.Range("G11")
.Range("C28") = START.Range("G12")
End With

' *************************
' Logファイルに書き出す
' *************************
With ThisWorkbook.Worksheets("Log")
.Range("A65536").End(xlUp).Offset(1, 0).Value = START.Range("E4")
.Range("A65536").End(xlUp).Offset(0, 1).Value = START.Range("G7")
.Range("A65536").End(xlUp).Offset(0, 2).Value = START.Range("G8")
.Range("A65536").End(xlUp).Offset(0, 3).Value = START.Range("G9")
.Range("A65536").End(xlUp).Offset(0, 4).Value = START.Range("G10")
.Range("A65536").End(xlUp).Offset(0, 5).Value = START.Range("G11")
.Range("A65536").End(xlUp).Offset(0, 6).Value = START.Range("G12")
.Range("A65536").End(xlUp).Offset(0, 7).Value = START.Range("G13")
End With

' *************************
' Print out
' *************************
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

End Sub

------------------------------------------------------

Private Sub CommandButton2_Click()

' *************************
' 入力値のクリアー
' *************************
With ThisWorkbook.Worksheets("START")
.Range("G7:G9") = ""
.Range("G11:G12") = ""
End With

' *************************
' Worksheetsの削除
' *************************
Worksheets("New_User").Delete

End Sub

------------------------------------------------------

←クリック一票

Posted on Jan 13, 2007 at 23:22 in VBA | Permalink | Comments (0) | TrackBack (0)

スケジュール表作成（２）

下記のようなVBAを作成しました。
Workdayの計算より日付を持ってきています。
このソースがそのまま使えるものではありません。自分のメモです。

-------------------------------------------------------------

Private Sub Workbook_Open()

Sheets("START0").Activate

End Sub

-------------------------------------------------------------

Private Sub CommandButton1_Click()

Dim Sheet_name As String
Dim New_sheet_name As String
Dim Month_MMM As String
Dim Year_yyyy As String
Dim Year_yy As String
Dim TODAY_c As Date
Dim TODAY_mm As Integer
Dim START0, CALC As Object
Dim Workday(40) As String
Dim i, j, k As Integer

'***************************
' Worksheetの定義
Set START0 = ThisWorkbook.Worksheets("START0")
Set CALC = ThisWorkbook.Worksheets("CALC")

' シート名を取得 yyyy-mm
Sheets("START0").Activate
Sheet_name = "H" & Range("I8") & Range("J8") & "-" & Range("M8") & Range("N8")

'***************************
' 年月を取得
Month_MMM = Format(Range("G6"), "mmm")
Month_mm = Format(Range("G6"), "mm")
Year_yyyy = Format(Range("G6"), "yyyy")
Year_yy = Format(Range("G6"), "yy")

'**************************
' 2/2のシート作成
'**************************
' 2/2のシートをコピー
Sheets("ORG").Select
Sheets("ORG").Copy After:=Sheets(3)
Sheets("ORG (2)").Name = Sheet_name & "-(2)"

' 追加したシートの名前を取得
New_sheet_name = Worksheets(4).Name

' 変更箇所
With Worksheets(New_sheet_name)
      .Range("S5") = START0.Range("I8")
      .Range("T5") = START0.Range("J8")
      .Range("V5") = START0.Range("M8")
      .Range("W5") = START0.Range("N8")
      .Range("C11") = START0.Range("G10")
      .Range("C13") = START0.Range("G12")
      .Range("Z5") = "2/2"
End With

'**************************
' 1/2のシート作成
'**************************
' 1/2のシートをコピー
Sheets("ORG").Select
Sheets("ORG").Copy After:=Sheets(3)
Sheets("ORG (2)").Name = Sheet_name & "-(1)"

' 追加したシートの名前を取得
New_sheet_name = Worksheets(4).Name

' 変更箇所
With Worksheets(New_sheet_name)
      .Range("S5") = START0.Range("I8")
      .Range("T5") = START0.Range("J8")
      .Range("V5") = START0.Range("M8")
      .Range("W5") = START0.Range("N8")
      .Range("C11") = START0.Range("G10")
      .Range("C13") = START0.Range("G12")
      .Range("B21") = "hoge-BANK-" & Month_MMM & Year_yy
      .Range("B22") = "BANK-" & Month_MMM & "-" & Year_yyyy
End With

'**************************
' Working day を求める
'**************************
' 来月を識別
TODAY_c = Range("G6")
TODAY_mm = Month(DateAdd("m", 1, TODAY_c))

ThisWorkbook.Worksheets("calc").Activate

i = 3
j = 1

k = CALC.Range("A65536").End(xlUp).Row

' 配列Workdayにddを取り込む
For i = 3 To CALC.Range("A65536").End(xlUp).Row
      If CALC.Cells(i, 2) = TODAY_mm Then
         Workday(j) = CALC.Cells(i, 5)
         j = j + 1
      End If
Next i

' 1/2にddを入れ込む
'*******************
Worksheets(4).Activate

i = 0
j = 1
k = 23

While i < 10
      If Workday(j) <> "" Then
         Worksheets(4).Cells(k, 2) = "hoge-BANK-DAY" & Format(Workday(j), "dd")
         i = i + 1
         j = j + 1
         k = k + 1
      Else
         j = j + 1
      End If
Wend

' 2/2にddを入れ込む
'*******************
Worksheets(5).Activate

i = 0
k = 21

While j < 32
      If Workday(j) <> "" Then
         Worksheets(5).Cells(k, 2) = "hoge-BANK-DAY" & Format(Workday(j), "dd")
         i = i + 1
         j = j + 1
         k = k + 1
      Else
         j = j + 1
      End If
Wend

Worksheets(4).Activate

End Sub

-------------------------------------------------------------

←クリック一票

Posted on Jan 05, 2007 at 07:33 in VBA | Permalink | Comments (0) | TrackBack (0)

スケジュール表作成（１）

営業日を計算させるため、下記のようなシートを作成しました。

--Cell A1
1/1の日付　例）2007/1/1

--Cell B1 (何月かを判定)
=MONTH(A1)

--Cell C1 (土日と月末だったら"1"返す)
=IF(OR(WEEKDAY(A1,2)>=6,A1=EOMONTH(A1,0)),"1","")

--Cell D1 (祝祭日をマニュアルで、"1"を入力)

--Cell E1 (土日、月末、祝祭日でなければ日付を返す)
=IF(AND(C1="",D1=""),A1,"")

--Cell F1 (曜日を判定　第２引数を"2"にすると月曜日が"1")
=WEEKDAY(A1,2)

「Workday_calc.xls」をダウンロード

A1:F1を下のCellへハンドルすると１年間のスケジュールを
作成することができます。

--参考　日本国民の祝・祭日

元日 1/1
成人の日 1月第2月曜日
建国記念の日 2/11
春分の日 3/21
昭和の日 4/29
憲法記念日 5/3
みどりの日 5/4
こどもの日 5/5
海の日 7月の第3月曜日
敬老の日 9月の第3月曜日
秋分の日 9/23
体育の日 10月の第2月曜日
文化の日 11/3
勤労感謝の日 11/23
天皇誕生日 12/23

* Wikipediaを参照しました。

←クリック一票

Posted on Jan 03, 2007 at 03:33 in Excel, VBA, アプリケーション | Permalink | Comments (0) | TrackBack (0)

エクセル　入力フォーム

エクセルを使用して入力フォームを利用した住所録を作成しました。
関連するセルを選択して、[データ]-[フォーム]でも同様に入力フォームは
呼び出せます。

--ThisWorkbookに書いたVBA
---------------------------
Private Sub Workbook_Open()

UserForm1.Show

End Sub
---------------------------

--UserFormに書いたVBA
---------------------------
Private Sub UserForm_Initialize()

' UserForm1を起動したときの初期設定（ComboBox）
With UserForm1.ComboBox1
         .AddItem "様"
         .AddItem "殿"
         .AddItem "御中"
         .AddItem "宛"
End With

End Sub
---------------------------

---------------------------
Private Sub CommandButton1_Click()

' 各入力値をセルに書き込む
With Worksheets("Main")
         .Range("A65536").End(xlUp).Offset(1, 0) = "〒"
         .Range("A65536").End(xlUp).Offset(0, 1) = TextBox1.Value
         .Range("A65536").End(xlUp).Offset(0, 2) = TextBox2.Value
         .Range("A65536").End(xlUp).Offset(0, 3) = TextBox3.Value
         .Range("A65536").End(xlUp).Offset(0, 4) = TextBox4.Value
         .Range("A65536").End(xlUp).Offset(0, 5) = TextBox5.Value
         .Range("A65536").End(xlUp).Offset(0, 6) = TextBox6.Value
         .Range("A65536").End(xlUp).Offset(0, 7) = ComboBox1.Value
         .Range("A65536").End(xlUp).Offset(0, 8) = CheckBox1.Value
         .Range("A65536").End(xlUp).Offset(0, 9) = CheckBox2.Value
         .Range("A65536").End(xlUp).Offset(0, 10) = CheckBox3.Value
End With

Call CommandButton2_Click

End Sub
---------------------------

---------------------------
Private Sub CommandButton2_Click()

      ' 入力値をクリアーする
      TextBox1.Value = ""
      TextBox2.Value = ""
      TextBox3.Value = ""
      TextBox4.Value = ""
      TextBox5.Value = ""
      TextBox6.Value = ""
      ComboBox1.Value = ""
      CheckBox1.Value = "False"
      CheckBox2.Value = "False"
      CheckBox3.Value = "False"

End Sub
---------------------------

--標準モジュールに書いたVBA　ワードファイルを開きます。
---------------------------
Sub Open_Wordfile()

Dim File_name As String

Open_wrd = Shell("WINWORD.EXE H:\差込印刷\差込印刷.doc", 1)

End Sub
---------------------------

←クリック一票

Posted on Oct 09, 2006 at 13:11 in VBA | Permalink | Comments (0) | TrackBack (0)

VBA 消費税計算

エクセルにて消費税を研鑽させるVBAを書いてみました。

----
Private Sub Run_Click()
Dim hontai As Currency
Dim tax As Currency
Dim all As Currency

'消費税率
'******************************
Const Duty As Double = 0.05
'******************************

'初期値設定
'------------------------------
hontai = input1.Value
tax = Input2.Value
all = Input3.Value

'計算
'------------------------------
If hontai <> 0 Then
         '販売価格が分かるケース
         tax = hontai * Duty
         all = hontai * (1 + Duty)

      ElseIf tax <> 0 Then
            '消費税が分かるケース
            hontai = tax / Duty
            all = (tax / Duty) + tax

      ElseIf all <> 0 Then
            '税込価格がが分かるケース
            hontai = all / (1 + Duty)
            tax = (all / (1 + Duty)) * Duty
End If

'計算結果出力
'--------------------------------
hontai = Application.RoundUp(hontai, 0) '小数第一位を切り上げ
tax = Application.RoundDown(tax, 0)    '小数第一位を切り捨て
all = Application.RoundUp(all, 0)       '小数第一位を切り上げ

input1.Value = Format(hontai, "###,###")       'コンマ挿入
Input2.Value = Format(tax, "###,###")          'コンマ挿入
Input3.Value = Format(all, "###,###")          'コンマ挿入

End Sub
----

←クリック一票

Posted on Oct 06, 2006 at 23:20 in VBA | Permalink | Comments (0) | TrackBack (0)

Excelからバッチファイルの実行

ExcelのVBAを使用して、バッチファイルを実行する。

----
Sub SCP()

　Dim SCP As Double
　Dim File_Name As String

　' 実行するファイルのフルパスをセルC2に指定しておきます
File_Name = Range("B2").Value

SCP = Shell(File_Name, vbNormalFocus)

End Sub
----

Shell関数の第二引数は
vbHide 0 フォーカスを持ち、非表示にされるウィンドウ。
vbNormalFocus 1 フォーカスを持ち、元のサイズと位置に復元されるウィンドウ
vbMinimizedFocus 2 フォーカスを持ち、最小化表示されるウィンドウ
vbMaximizedFocus 3 フォーカスを持ち、最大化表示されるウィンドウ
vbNormalNoFocus 4 最後にウィンドウを閉じたときのサイズと位置に復元されるフォーカスを持たないウィンドウ。現在アクティブなウィンドウは、アクティブのままです。
vbMinimizedNoFocus 6 最小化表示されるフォーカスを持たないウィンドウ。現在アクティブなウィンドウは、アクティブのままです。

←クリック一票

Posted on Oct 02, 2006 at 07:50 in VBA | Permalink | Comments (0) | TrackBack (0)

VBA 空白の列を削除

エクセルにて、空白の列を削除するVBAです。
ただし、空白の列が続いた場合、２つ目の列は削除できません。
想定しているのは１列おきのデータです。

-----
Sub Retsu Keshi Macro()

Application.ScreenUpdating = False

Dim i As Integer

' １から最後の列まで繰り返す
For i = 1 To Range("A65536").End(xlUp).Row

' Cells(i, 1)が空白だったら、その列を削除する
If Cells(i, 1) = "" Then
Cells(i, 1).Select
ActiveCell.EntireRow.Delete
End If

Next i

Cells(1,1).Select

Application.ScreenUpdating = True

End Sub
-----

←クリック一票

Posted on Aug 21, 2006 at 21:46 in VBA | Permalink | Comments (0) | TrackBack (0)

VBA 定期的にデータ取得

ある一定の間隔ごとにSheet1のE21を”値”と
してSheet2へ取得・記録するVBAです。

-----
Private Sub CommandButton1_Click()

Dim Cnt As Interior

'繰り返し開始　ここから
For i = 1 To Cnt

'Sheet1　リフレッシュ
      Sheets("Sheet1").Select
      ActiveWorkbook.RefreshAll

      Sheets("Sheet2").Select
With Worksheets("Counter")
      .Range("A65536").End(xlUp).Offset(1, 0).Value = "=NOW()"
      .Range("A65536").End(xlUp).Select

'データを”値”として貼り付け
Selection.Copy
      Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
         False, Transpose:=False

      .Range("B65536").End(xlUp).Offset(1, 0).Value = "=Sheet1!E21"
      .Range("B65536").End(xlUp).Select

'データを”値”として貼り付け
Selection.Copy
      Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
         False, Transpose:=False

      .Range("A65536").End(xlUp).Select
      'セルの選択解除
Application.CutCopyMode = False

'５分間待機
      Application.Wait Time:=Now + TimeValue("00:05:00")
   End With

   Next
'繰り返し終了　ここまで

End Sub
-----

--参考ページ
http://www.asahi-net.or.jp/~ef2o-inue/top01.html
http://www.moug.net/

←クリック一票

Posted on May 29, 2006 at 07:03 in VBA | Permalink | Comments (0) | TrackBack (0)

エクセル　フッダー作成マクロ

エクセルにてフッダーの中央に”ファイル保存先フルパス\ファイル名”、
右端に”ページ数 / ページ総数”を挿入するマクロを作成しました。

----
Sub AutoPath()

Application.ScreenUpdating = False

Dim myfile As String

mypath = ActiveWorkbook.FullName

With ActiveSheet.PageSetup
      .CenterFooter = mypath
      .RightFooter = "&P / &N"
End With

Application.ScreenUpdating = True

End Sub
----

どのエクセルブックにおいても使用する場合は、個人用マクロブックである
"PERSONAL.XLS"に保存します。

ボタンに登録する場合は、
[ツール] - [ユーザー設定] "コマンド"タブにて
分類を”マクロ”を選びます。
作成したボタンを右クリックして”マクロの登録”をすれば完成です。

←クリック一票

Posted on Mar 30, 2006 at 09:42 in VBA | Permalink | Comments (0) | TrackBack (0)