18 posts categorized "VBA"

Oct 16, 2009

エクセル VBA 範囲指定

VBAにて基本となる、セル指定方法です

--Cellsを使う場合

・セルB4を選択
Cells(2,4).Select

・変数との組み合わせ
Cells(i,4).Select


--Rangeを使う場合

・単一セルB2を選択
Range("B2").Select

・複数のセルを選択する
Rnage("B2","D4").Select

・セル範囲A1:B3を選択する
Range("A1:B3").Select

・範囲指定にCellsを使う
Range(Cells(1,1),Cells(3,2)).Select


--Rowsを使う場合

・単一行を選択
Rows(2).Select

・複数行を選択
Rows("2:5")


--Columnsを使う場合

・単一列の選択の場合
Columns("B").Select

・複数の列を選択の場合
Columns("B:D").Select

その他
EntireRow
EntireColumn

--参考ページ
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_cell.html

  ブログランキング

| | Comments (0) | TrackBack (0)

Apr 24, 2009

エクセル VBA プリンタを指定して印刷

エクセルVBAで、プリンタを指定して印刷するソースです。

  ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:="PRINTER01", Collate:=True
 ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:="PRINTER02", Collate:=True
 ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:="PRINTER03", Collate:=True
  ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:="PRINTER04", Collate:=True
  ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:="PRINTER05", Collate:=True

プリンタが複数台あり、それぞれ印刷したい場合(印刷テスト)や
プリンタを指定して印刷することができます。←そのままです。


  ブログランキング

| | Comments (0) | TrackBack (0)

Apr 17, 2009

エクセル VBA ピポットテーブルを作成

VBAにてピポットテーブルを作成する方法です。

----
Dim COUNT as integer

COUNT = Range("A65536").End(xlUp).Row  ' 最後のレコードの行番号を入手

ActiveSheet.PivotTableWizard xlDatabase, Range(Cells(1, 1), Cells(COUNT, 10)), "", "集計テーブル"

ActiveSheet.PivotTables("集計テーブル").AddFields RowFields:=Array("ROW-01", _
    "ROW-02"), ColumnFields:=Array("COL-01", "COL-02")

With ActiveSheet.PivotTables("集計テーブル").PivotFields("DATA")
    .Orientation = xlDataField
    .Caption = "合計 / DATA"
    .Function = xlSum
End With

ActiveWorkbook.ShowPivotTableFieldList = True
----

今回のポイントは、レコード数が可変であっても対応するようにしました。
斜線字を環境に応じて変更します。
また、必要に応じてピポットテーブルの作成をマクロに記録し、
コピー&ペーストにて編集しましょう。

--参考ページ
http://www.serpress.co.jp/excel/vba027.html
http://www11.plala.or.jp/koma_Excel/index.html


  ブログランキング

| | Comments (0) | TrackBack (0)

Apr 16, 2009

エクセル VBA ファイル・フォルダの存在確認

VBAにて、ファイルもしくはフォルダのある無しを判別する方法です。

--ファイルの判別
Dim FileExist, File_Path As String

File_Path = "D:\tmp\test.txt"
FileExixt = Dir(File_Path)

D:\tmp\test.txtが存在する場合、FileExitにはファイルのパスが代入されます。
ファイルが存在しない場合は空白("")が代入されます。

例)
Dim File_Path as String

File_Path = "D:\tmp\test.txt"

If Dir(File_Path) = "" Then
        Goto Label1 'ファイルが存在しない場合

Else
        '*** 処理 *** 'ファイルが存在する場合

End if

Label1:
        '*** 別処理 ***

--フォルダ(ディレクトリ)の場合
Dim DirectoryExist, DirectoryPath As String

DirecrotyPath = D:\tmp
DirectoryExist = Dir(DirectoryPath, vbDirectory)

ファイルの場合と同じように、D:\tmpが存在する場合、DirectoryExistには
フォルダのパスが代入され、フォルダが存在しない場合は空白("")が
代入されます。

これらを使うと、ある特定のファイルを開こうとした際に、ファイルが
存在するかしないかの判別を行い、エラーを回避することができます。
(*開こうとするファイルが存在しない場合、エラーでプログラムが
止まってしまいます)


--参考ページ
http://www.k1simplify.com/vba/tipsleaf/leaf243.html


  ブログランキング

| | Comments (0) | TrackBack (0)

Apr 15, 2009

Excel VBA Tips (1)

Excel VBA のちょっとしたTipsです。

--画面表示を非表示にする
Application.ScreenUpdating = False

' *** 処理 ***

Application.ScreenUpdating = True

画面表示を非表示にすると、処理速度が上がります。

--シートを表示する・非表示にする
Sheets("tmp").Visible = xlSheetVisible
Sheets("tmp").Visible = xlSheetVeryHidden

シート"tmp"を表示にしたり、非表示にしたりします。

--カレントパス
ThisWorkbook.Path

例)カレントパスにブックを保存する
Dim Sheet_name As String
Sheet_name = ThisWorkbook.Worksheets("tmp").Range("A1")

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheet_name & ".xls"



  ブログランキング

| | Comments (0) | TrackBack (0)

May 21, 2008

エクセルで自動印刷

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

自動印刷する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

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

考えたフローは、
1.印刷をする
2.イベントのチェックを止める
3.データのクリアー
4.イベントのチェックを始める

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

とするとよいようです。


  ブログランキング

| | Comments (0) | TrackBack (0)

Mar 28, 2008

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
-------------------------------


  ブログランキング

| | Comments (0) | TrackBack (0)

Jan 04, 2008

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
----------------------


  ブログランキング

| | Comments (0) | TrackBack (0)

May 10, 2007

簡単な判別 エクセル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
------------------------------

  ブログランキング

| | Comments (0) | TrackBack (0)

Jan 13, 2007

入力フォーム

テンプレートとなる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

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

←クリック一票

| | Comments (0) | TrackBack (0)