Excel VBA ノート(サンプルコード)

Hide Tamura の Excel VBA ノート

Excel-VBA データ集計、可視セルをコピー Selection.Subtotal Selection.SpecialCells(xlCellTypeVisible)

Function データ加工_後半()

    '集計加工シートから集計Workシートにコピーして、
    '並べ替えをして、集計して、集計シートに転送している

    Dim r As Long, lngLastRow As Long, lngPasteRow As Long
    Dim i As Long
    Dim KakouSheet As String, SyukeiSheet As String, SyukeiWorkSheet As String
    Dim lngTuki As Long, TargetCol As Long
    Dim strTekiyou As String
    Dim lngGetTekiyou As Long
    
    '加工済みシート
    KakouSheet = ActiveSheet.Name
        
    '----- 設定 開始 -----
    
    '集計処理に使うシート
    SyukeiWorkSheet = "集計WORK"
    
    '集計結果に使うシート
    SyukeiSheet = "集計"
    
    '貼りつけ行を指定
    lngPasteRow = Cells(1, "B").End(xlDown).Offset(1).Row
    
    '----- 設定 終了 -----
        
    Application.ScreenUpdating = False
    
    r = Application.Rows.Count

    '##############
    '#  並べ替え
    '##############
    
    Sheets(SyukeiWorkSheet).Cells.ClearContents
    Sheets(KakouSheet).Activate
    
    Cells(lngPasteRow - 1, "B").Select
    Selection.CurrentRegion.Copy
    
    Sheets(SyukeiWorkSheet).Select
    Cells(lngPasteRow - 1, "B").Select
    ActiveSheet.Paste
    
    Columns("D:E").Select
    Selection.ClearContents
    
    Cells(lngPasteRow - 1, "B").Select
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("B6"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin
    
    '##############
    '#   集 計
    '##############

    'シート名から月を求める
    lngTuki = Val(KakouSheet)
    
    '集計シートのターゲット行を求める
    TargetCol = 2 + (lngTuki - 1) * 5

    Sheets(SyukeiWorkSheet).Activate
    Cells(lngPasteRow - 1, "B").Select
    Selection.CurrentRegion.Select
    
    '集計処理
    Application.CutCopyMode = False
    Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    ActiveSheet.Outline.ShowLevels RowLevels:=2
    
    Sheets(SyukeiWorkSheet).Activate
    Cells(lngPasteRow - 1, "B").Select
    Selection.CurrentRegion.Select
    
    '可視セルのコピー
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
       
    Sheets(SyukeiSheet).Select
    Cells(4, TargetCol).Select
    ActiveSheet.Paste
    Cells(2, TargetCol).Select
    
    Cells.EntireColumn.AutoFit
    
    Sheets(SyukeiWorkSheet).Select
    ActiveSheet.Outline.ShowLevels RowLevels:=3
    
    Cells(lngPasteRow - 1, "B").Select
    Selection.CurrentRegion.Select
    
    Application.CutCopyMode = False
    Selection.RemoveSubtotal
    Range("A1").Select
    
End Function


 

Excel-VBA Excelのクローズボタン「×」を無効にし、プログラム上でブックを閉じたい(終了させたい) Workbook_BeforeClose

起動時に セルのフラグ保存セルをクリア
ここでは、A1セル

Private Sub Workbook_Open()

    Sheets(1).Unprotect
    Sheets(1).Cells(1).ClearContents

End Sub


プログラムの実行ボタンを押したタイミングで、フラグ保存セルに、フラグ「1」を代入
起動直後は、クローズボタン「×」でExcelを閉じられるように、実行ボタンを押したタイミングでフラグを立てる
ここでは、A1セル

Sub Sepia実行()

    Sheets(1).Unprotect
    Sheets(1).Cells(1).Value = 1

End Sub


クローズボタン「×」でExcelを閉じようとすると、フラグが立っているので、メッセージを表示して、クローズをキャンセルする

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    If Sheets(1).Cells(1).Value = 1 Then
    
        MsgBox "メニューの終了ボタンで終わらせてください。", vbExclamation, "終了"
        Cancel = True
        
        Exit Sub
    
    End If

    Application.Quit

End Sub


メニューの終了ボタンでは、フラグをクリアしてからクローズする

Sub 終了処理()
   
    Sheets(1).Unprotect
    Sheets(1).Cells(1).ClearContents

'保存終了
    ThisWorkbook.Close SaveChanges:=True

End Sub



Excel-VBA データをCSVファイル形式に書き出す SaveAs FileFormat:=xlCSV

Sub CSVファイル作成()
    Dim TMPNAME As String, txtTMPNAME As String, myPath As String, szStr As String
    Dim Response As String
    Dim strMySheet As String
    Dim lngLastRow As Long
    
    '余裕を持った使用最大行数
    Const MaxRowsCount As Long = 30000
          
    'このファイルへのPath
    myPath = ThisWorkbook.Path
    
    'このファイルの名前
    TMPNAME = ThisWorkbook.Name
    
    '現在のシート名
    strMySheet = ActiveSheet.Name
    
    'テキスト用ファイルの名前(このファイル名.csv)
    txtTMPNAME = Left(TMPNAME, Len(TMPNAME) - 5) & ".csv"
    
    szStr = szStr & "CSVファイルを作成します" & Chr(13) & Chr(10)
    szStr = szStr & "" & Chr(13) & Chr(10)
    szStr = szStr & "作成場所 → このファイルと同じ階層(フォルダ)" & Chr(13) & Chr(10)
    szStr = szStr & "(" & myPath & ")" & Chr(13) & Chr(13) & Chr(10)
    szStr = szStr & "ファイル名 → " & txtTMPNAME & Chr(13) & Chr(10)
    
    Response = MsgBox(prompt:=szStr, Buttons:=vbOKCancel + vbInformation, Title:="CSVファイルの作成")
    If Response = vbCancel Then Exit Sub
    
    Application.ScreenUpdating = False
    
    'テキスト用ファイルの名前(このファイル名.csv)にPathを含める
    txtTMPNAME = myPath & "\" & txtTMPNAME
    
    'データ最終行を取得
'    ActiveSheet.Select
    lngLastRow = Cells(MaxRowsCount, "D").End(xlUp).Row
    
    '★データ範囲を選択
    Range("D4", Cells(lngLastRow, "I")).Select
    Selection.Copy
    
    'CSV作成用のワークシートを追加
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    
    '追加したシートに貼り付け
    Worksheets(Worksheets.Count).Select
    Range("A1").Select
    ActiveSheet.Paste
    
    lngLastRow = Cells(MaxRowsCount, "A").End(xlUp).Row
    
    
'-----------------------------------------------
    'データがなかった場合 (フィールド名がある場合)
    If lngLastRow = 1 Then
        MsgBox "該当データがありませんでした"

        Worksheets(Worksheets.Count).Select

        Application.DisplayAlerts = False
        ActiveWindow.SelectedSheets.Delete
        Application.DisplayAlerts = True
        
        Sheets(strMySheet).Select

        Exit Sub

    End If
    
'    'データがなかった場合 (フィールド名がない場合)
'    If lngLastRow = 1 And Cells(1).Value = Empty Then
'        MsgBox "該当データがありませんでした"
'
'        Worksheets(Worksheets.Count).Select
'
'        Application.DisplayAlerts = False
'        ActiveWindow.SelectedSheets.Delete
'        Application.DisplayAlerts = True
'
'        Sheets(strMySheet).Select
'
'        Exit Sub
'
'    End If
'-----------------------------------------------
    
    Application.DisplayAlerts = False

    'CSVファイルの作成
    ActiveSheet.Copy
    ActiveSheet.SaveAs Filename:=txtTMPNAME, FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.Close
    
    '追加したシートを削除
    Worksheets(Worksheets.Count).Select
    ActiveWindow.SelectedSheets.Delete
    
    Application.DisplayAlerts = True
    
    Sheets(strMySheet).Select
    MsgBox "作成完了しました", vbInformation

End Sub


 ↓ facebook のフォローで応援してください。お願いします。



Microsoft Office ブログランキングへ


 

Excel-VBA CSVファイルがエラーで開けない(SYLK ファイルであることを確認しましたが、読み込むことができません)

一行目の出だしが、『ID』で始まるCSVファイル、または、TXTファイルを Excelで開こうとすると、

28

↓ ↓ ↓ ↓ ↓ ↓

『 Excelは'ファイル名.txt'がSYLK ファイルであることを確認しましたが、読み込むことができません。ファイルにエラーが含まれるか、SYLK ファイル形式でない可能性があります。異なるファイル形式でそのファイルを開くには、[OK] をクリックしてください。 

というエラーが表示される。

これは、Excelが、CSV形式のCSVファイル、TXTファイルを、SYLKと認識してしまう為だ。
対応方法は、一行目の出だしが、IDでなければ良いだけだ。
「'ID」にしたり、「"ID"」にしたり、「商品ID」にしたり、一時的に変更すれば良い。

突然、CSVファイルがエラーで読めなくなり、困っていたら、こんな事が原因でした。


 ↓ facebook のフォローで応援してください。お願いします。



Microsoft Office ブログランキングへ



Excel-VBA CSVファイルを1行づつ読み込む Split関数 / Input / Line Input

小さいCSVファイルならば、高速に読み込むことを考えず、Textファイルに変換してから読み込まなくても良いだろう。

コードも短く、読みやすいのが利点。また、全てのデータを読み込まずに必要なデータを入手したら止めることもできるし、データを処理しながら読み込むこともできる。

まず、Line Input と、Split関数を用いた方法で、1行毎のデータを、カンマをもとにSpliet関数で配列に入れている。

Sub Sample()
    Dim text1 As String
    Dim myData1 As Variant
    Dim i As Long
    
    Open "C:\Users\HIDE\Desktop\新しいフォルダー\myBook1.csv" For Input As #1
    
    Cells.ClearContents
    Cells(1).Select
    
    Do Until EOF(1)
        Line Input #1, text1
    
        myData1 = Split(text1, ",")
    
        For i = 0 To 3
        
            Cells(ActiveCell.Row, i + 1).Value = myData1(i)
        
        Next i
        
        ActiveCell.Offset(1).Select
    
    Loop
    
    Close #1

End Sub


こちらは、Input で、1行毎にフィールドの要素を配列に入れていく方法

Sub Sample2()
    Dim text1 As String
    Dim myData(3) As Variant
    Dim i As Long
    
    Open "C:\Users\HIDE\Desktop\新しいフォルダー\myBook1.csv" For Input As #1
    
    Cells.ClearContents
    Cells(1).Select
    
    Do Until EOF(1)
        Input #1, myData(0), myData(1), myData(2), myData(3)
    
        For i = 0 To 3
        
            Cells(ActiveCell.Row, i + 1).Value = myData(i)
        
        Next i
        
        ActiveCell.Offset(1).Select
    
    Loop
    
    Close #1

End Sub

 ↓ facebook のフォローで応援してください。お願いします。



Microsoft Office ブログランキングへ



 

Excel-VBA マクロ有効ブックとして保存

マクロを書いたブックの保存方法です。Excel2013を例に解説します。

VBEは独立したソフトではなく、Excelブックに付属した機能だと理解してください。
その為、Excel本体を保存するとVBEの内容も保存されます。逆に、VBEで保存した場合でも、Excel本体の変更も保存されます

保存方法について簡単に説明しますと、ブックを「名前を付けて保存」する際に、ファイルの種類を「Excel マクロ有効ブック(*.xlsm)」にするだけ。


以下、詳細に説明します。

VBE側からの保存方法する場合

VBEで、「Ctrl」+「S」(「Ctrl」キーを押しながら「S」キー)を押します。まだ、一度も保存されていない状態なので、「名前を付けて保存」ダイアログボックスが表示されます。

Excel本体側からの保存方法する場合

「F12」キーを押します。「名前を付けて保存」ダイアログボックスが表示されます。

11


「名前を付けて保存」が表示されたら

ファイルの種類」のドロップダウンリストから
Excel マクロ有効ブック(*.xlsm)」を選択します。

ファイル名を入力し、「保存」ボタンを押します。これで、マクロ有効ブックとして保存されます。

ファイルの種類が「Excel ブック(*.xlsx)」のままですと、VBEに書いたマクロが全て無くなってしまいますので注意してください。

保存したマクロ有効ブックは、ファイルのアイコンが、「!」マーク付きの次のようなデザインになります。

13


パソコンのキーボードに「F12」キーが無い場合

次の方法で「名前を付けて保存」ダイアログボックスを表示させてください。

「Ctrl」+「S」(「Ctrl」キーを押しながら「S」キー)を押します。または、リボンの「ファイル」タブを押します。

12

左のグリーンのメニュから、「名前を付けて保存」を選択し、「コンピューター」を選択して「参照」を選択します。
「名前を付けて保存」ダイアログボックスが表示されます。



Microsoft Office ブログランキングへ



 

★Excel 2013対応 Excel-VBA Excel マクロを有効にする方法(コンテンツの有効化)

マクロが書かれているブックは、「コンテンツの有効化」を行い、マクロを有効にして利用します。

では、マクロを有効にする方法をご紹介します

マクロが書かれているブックを開くと、セキュリティー警告が表示されます。
セキュリティー警告が表示されない場合は、マクロが使えない設定になっていますので、設定を変える必要があります。それも下に書いておきます。

 [ Excel 2013, 2010 ] の場合  
「セキュリティー警告」が表示されましたら、[コンテンツの有効化] を選択してください。

14


[ Excel 2007 ] の場合 
「セキュリティー警告」が表示されましたら、 [オプション…] を押します。

15

次図の「Microsoft Office セキュリティ オプション」が表示されましたら、[このコンテンツを有効にする]  を選択して「OK」ボタンを押してください。

16


 [ Excel 2003 ] の場合
「セキュリティー警告」ダイアログボックスが表示されましたら、[マクロを有効にする] を選択します。

17

 
セキュリティ警告が表示されない場合は、Excelのセキュリティーレベルの設定を行います。

[ Excel 2013, 2010 ]の場合
1.[スタート]から Excel を起動
※Excel2013では、「お勧めのテンプレート」から「空白のブック」を選択してExcelを起動させてください
2.画面上部の[ファイル]タブを選択し、左のメニュから[オプション]を選択

18

3.[Excelのオプション]ウインドウが表示されますので、左のメニュから[セキュリティ センター]を選択
4.右の「Microsoft Excel セキュリティ センター」から、「セキュリティ センターの設定」ボタンを選択。

19

5.[セキュリティ センター]ウインドウが表示されますので、左のメニュから[マクロの設定]を選択
6.右の「マクロの設定」で、2番目の「警告を表示してすべてのマクロを無効にする」を選択

20

7.[OK]ボタンを押して、Excelを閉じる

[ Excel 2007 ]の場合
1.[スタート]から Excel を起動
2.左上の丸いOfficeマークをクリックします。

21

3.表示されたメニュの下の[Excelのオプション]ボタン選択 

22

4.[Excelのオプション]ウインドウが表示されますので、左のメニュから[セキュリティ センター]を選択
5.右の「Microsoft Office Excel セキュリティ センター」から、「セキュリティ センターの設定」ボタンを選択

23

6.[セキュリティ センター]ダイアログの、左のメニュから[マクロの設定]を選択
7.右の「マクロの設定」で、2番目の「警告を表示してすべてのマクロを無効にする」を選択

24

8.[OK]ボタンを押して、Excelを閉じる

[ Excel 2003 ]の場合
1.[スタート]から Excel を起動
2.メニューバーの[ツール]メニュから、[マクロ]-[セキュリティ]を選択

25

3.[セキュリティ]ダイアログから[セキュリティ レベル]タブを選択
4.[セキュリティ レベル]パネルから、[中]を選択します
   ( [高] はマクロが利用できなくなります。 [低] はセキュリティ上、推奨しません)

26

 5.[OK]ボタンを押し、Excelを閉じる



Microsoft Office ブログランキングへ



Excel-VBA ユーザーフォームを使い、ブックにパスワードを設定する Asc関数


pass

パスワードは、Asciiコードを取得し、8文字以上で、半角の数字と英字の両方が含まれるようにしています。

Option Explicit

Private Sub CheckBox1_Click()

    If Me.CheckBox1.Value = True Then
        Me.TextBox2.PasswordChar = ""
        Me.TextBox3.PasswordChar = ""
    Else
        Me.TextBox2.PasswordChar = "*"
        Me.TextBox3.PasswordChar = "*"
    End If
    
End Sub

Private Sub CommandButton1_Click()
    Dim strNewPass As String
    Dim lngPassLen As Long
    
    Dim i As Long
    
    Dim blnFlag0 As Boolean, blnFlagA As Long, blnFlag0A As Boolean
    Dim blnTextBox1 As Boolean, blnTextBox2 As Long, blnTextBox3 As Boolean
    
    Dim strStartSheet As String
    Dim strStartZoomRange As String
    Dim strStartCell As String
    Dim lngStarCol As String 'スタート時の画面のカラム
        
    strNewPass = Me.TextBox2.Text
    lngPassLen = Len(strNewPass)

    blnTextBox2 = False
    blnTextBox3 = False
    
    blnFlag0 = False
    blnFlagA = False
    blnFlag0A = False

    '入力チェック
    If Not (Me.TextBox2.Text = Empty) Then blnTextBox2 = True
    If Not (Me.TextBox3.Text = Empty) Then blnTextBox3 = True
    
    
    If blnTextBox2 = False And blnTextBox3 = False Then
        'パスワード入力なし
        
        MsgBox "入力がありません", vbExclamation
        Application.ScreenUpdating = True
        Exit Sub
    
    End If
    
    'TextBox2.Text が8文字以上かチェック

    If lngPassLen < 8 Then
        MsgBox "パスワードは8文字以上で設定して下さい", vbExclamation
        Me.TextBox2.SetFocus
        Exit Sub
    End If
    
    'TextBox2.Text に英語と数字の両方が含まれているかチェック
    
    For i = 1 To lngPassLen
    
        '0-9
        If (Asc(Mid(strNewPass, i, 1)) >= 48 And Asc(Mid(strNewPass, i, 1)) <= 57) Then
            blnFlag0 = True
        End If
        
        'A-Z a-z
        If (Asc(Mid(strNewPass, i, 1)) >= 65 And Asc(Mid(strNewPass, i, 1)) <= 90) Or _
        (Asc(Mid(strNewPass, i, 1)) >= 97 And Asc(Mid(strNewPass, i, 1)) <= 122) Then
        
            blnFlagA = True
        
        End If
    
        If blnFlag0 = True And blnFlagA = True Then
            blnFlag0A = True
            Exit For
        End If
        
    Next i

    If blnFlag0A = False Then
        MsgBox "パスワードは半角数字と半角英文字の両方が必要です", vbExclamation
        Exit Sub
    End If

    'TextBox2.Text とTextBox3.Text が同じかチェック

    If Not (Me.TextBox2.Text = Me.TextBox3.Text) Then
        MsgBox "新パスワードと確認パスワードが一致していません", vbExclamation
        Me.TextBox3.SetFocus
        Exit Sub
    End If
        
    'パスワード設定
    
    Workbooks(strPassBook).Sheets(strPassSheet2).Range(strPassCell).Value = strNewPass
    
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & ThisWorkbook.Name, Password:=strNewPass
    Application.DisplayAlerts = True
    
    MsgBox "パスワードを設定しました", vbInformation
        
    Unload Me
    Application.ScreenUpdating = True

End Sub

Private Sub TextBox3_Change()
    
    If Me.TextBox2.Value = Me.TextBox3.Value Then
        Me.CommandButton1.SetFocus
    End If

End Sub

Private Sub UserForm_Initialize()

    Me.CheckBox1.Value = False
    
End Sub
 

Excel-VBA ユーザーフォームのリストボックスにセル範囲の値を表示

Private Sub UserForm_Initialize()
    Dim i  As Long
    Dim lngLastRow As Long
    
    lngLastRow = Sheets(con相手科目).Cells(con最大科目数, 1).End(xlUp).Row
    Me.ListBox1.RowSource = con相手科目 & "!A2:A" & lngLastRow
    
End Sub

 ↓ facebook のフォローで応援してください。お願いします。



Microsoft Office ブログランキングへ




Excel-VBA Imageコントロールに写真を表示 LoadPicture(strImgPath)

Private Sub UserForm_Initialize()
    Dim strImgPath As String
    
    strImgPath = "C:\Users\HIDE\Pictures\新しいフォルダー\1.jpg"
    
    With UserForm1.Image1
        
        .Picture = LoadPicture(strImgPath)
        
        .PictureSizeMode = fmPictureSizeModeClip    '見える範囲だけ表示
'        .PictureSizeMode = fmPictureSizeModeStretch '引き延ばす(縦横比が崩れる)
'        .PictureSizeMode = fmPictureSizeModeZoom    'ズームして全体表示(縦横比維持)
        
    End With

End Sub

 ↓ facebook のフォローで応援してください。お願いします。



Microsoft Office ブログランキングへ


 


記事検索
Excel VBA ノートについて(注意事項)
このExcel VBA ノートは、Hide Tamura の個人的なVBAノートです。プログラムを再利用したり、コピペで入力の手間を省く為に作ったネット上のノートです。 その為、詳しい解説は書いておりません。エラー等のトラブルには責任は負いません。利用者の環境に合わせて書き換えてご利用ください。
ExcelVBA教室
Excel VBA 担当 Hide Tamura

Excel95? マクロシートがあった頃からExcelVBAを独学で利用しています。現在は、様々な企業様からVBAによる業務効率UPの為のお仕事を頂いております。既にお使いになっているファイルにVBAを利用することで、作業が楽になったり、時間も大幅に短縮されたなど、大変喜ばれています。

■VBA Expert
VBA Expert Standard Crown
ExcelVBA Standard(Odyssey)
Access VBA Standard(Odyssey)
Excel2002 VBA Standard(日本VBA協会)
■MICROSOFT OFFICE USER SPECIALIST
Microsoft Excel version2002 Expert
Microsoft Excel version2002


最新記事
Excelで作る経営計画
Excelで利益計画を立てましょう!会社にいくらの利益が必要で、その為の売上高は?

Excelで作る経営計画
Excel 関数 ノート
Excel関数を中心に、Excelの便利機能や、意外としらない使い方など書いていきます。

Excel 関数 ノート
Access VBAノート
Hide Tamura の個人的なVBAノートです。

頻繁に使うVBAコードなどを記録しコピペして使う為に作りました。お役に立てるようでしたら、お使いください。

Access VBAノート
アクセスカウンター

    • ライブドアブログ