●PERSONAL.●


********キーボードツール_ここから***************************
Option Explicit
Public nRow As Long
Public nCol As Long
------------------------------------------------
Sub auto_open()

Application.OnKey "{F1}", ""
Application.OnKey "+^I", "toUP"
Application.OnKey "+^J", "toLEFT"
Application.OnKey "+^K", "toRIGHT"
Application.OnKey "+^N", "toDOWN"
Application.OnKey "+^H", "DELETE"
Application.OnKey "+^B", "InsertLine"
Application.OnKey "+^O", "LineAutoFit"
Application.OnKey "+^P", "ColumnAutoFit"
Application.OnKey "+^L", "列幅折り返し表示"
Application.OnKey "+^D", "文字左詰め表示"
Application.OnKey "+^C", "文字中央揃い表示"
Application.OnKey "+^F", "文字右詰め表示"
Application.OnKey "+^M", "ウィンドウ最少化"
Application.OnKey "+^U", "ZoomUp"
Application.OnKey "+^Y", "ZoomDown"
Application.OnKey "+%{UP}", "charaBIG"
Application.OnKey "+%{DOWN}", "charaSMALL"
Application.OnKey "%{RIGHT}", "列幅微増"
Application.OnKey "%{LEFT}", "列幅微減"
Application.OnKey "+^T", "Cell結合"
Application.OnKey "%{UP}", "セル縦位置UP"
Application.OnKey "%{DOWN}", "セル縦位置DOWN"
Application.OnKey "+^%{RIGHT}", "FindNextRight"
Application.OnKey "+^%{LEFT}", "FindNextLeft"
Application.OnKey "+^%{UP}", "FindNextUp"
Application.OnKey "+^%{DOWN}", "FindNextDown"
Application.OnKey "^{PGDN}", "Next_Sheet_Active"
Application.OnKey "^{PGUP}", "Prior_Sheet_Active"

End Sub
------------------------------------------------
Sub toUP()

nRow = ActiveCell.Row
nCol = ActiveCell.Column

If nRow > 1 Then
Cells(nRow - 1, nCol).Select
End If

End Sub
------------------------------------------------
Sub toLEFT()

nRow = ActiveCell.Row
nCol = ActiveCell.Column

If nCol > 1 Then
Cells(nRow, nCol - 1).Select
End If

End Sub
------------------------------------------------
Sub toRIGHT()

Dim tmpCol As Long
nRow = ActiveCell.Row
nCol = ActiveCell.Column
tmpCol = nCol

If Selection.MergeCells Then
Do
If nCol = 256 Then Exit Sub
nCol = nCol + 1
Cells(nRow, nCol).Select
Loop Until Not Selection.MergeCells Or tmpCol <> ActiveCell.Column
Else
If nCol <> 256 Then Cells(nRow, nCol + 1).Select
End If

' If nCol <> 256 Then
' Cells(nRow, nCol + 1).Select
' End If

End Sub
------------------------------------------------
Sub toDOWN()

Dim tmpRow As Long
nRow = ActiveCell.Row
nCol = ActiveCell.Column
tmpRow = nRow

If Selection.MergeCells Then
Do
If nRow = 65536 Then Exit Sub
nRow = nRow + 1
Cells(nRow, nCol).Select
Loop Until Not Selection.MergeCells Or tmpRow <> ActiveCell.Row
Else
If nRow <> 65536 Then Cells(nRow + 1, nCol).Select
End If

' If nRow <> 65536 Then
' Cells(nRow + 1, nCol).Select
' End If

End Sub
------------------------------------------------
Sub FindNextRight()
nRow = ActiveCell.Row
nCol = ActiveCell.Column
Do
nCol = nCol + 1
If nCol > ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column Then
nCol = 1
nRow = nRow + 1
If nRow > ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row Then
nRow = 1
End If
End If
If Cells(nRow, nCol).Value <> "" Then
Cells(nRow, nCol).Select
Exit Do
End If
Loop

End Sub
------------------------------------------------
Sub FindNextLeft()

nRow = ActiveCell.Row
nCol = ActiveCell.Column
Do
nCol = nCol - 1
If nCol < 1 Then
nCol = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
nRow = nRow - 1
If nRow < 1 Then
nRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
End If
End If
If Cells(nRow, nCol).Value <> "" Then
Cells(nRow, nCol).Select
Exit Do
End If
Loop

End Sub
------------------------------------------------
Sub FindNextUp()

nRow = ActiveCell.Row
nCol = ActiveCell.Column
Do
nRow = nRow - 1
If nRow < 1 Then
nRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
nCol = nCol - 1
If nCol < 1 Then
nCol = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
End If
End If
If Cells(nRow, nCol).Value <> "" Then
Cells(nRow, nCol).Select
Exit Do
End If
Loop

End Sub
------------------------------------------------
Sub FindNextDown()

nRow = ActiveCell.Row
nCol = ActiveCell.Column
Do
nRow = nRow + 1
If nRow > ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row Then
nRow = 1
nCol = nCol + 1
If nCol > ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column Then
nCol = 1
End If
End If
If Cells(nRow, nCol).Value <> "" Then
Cells(nRow, nCol).Select
Exit Do
End If
Loop

End Sub
------------------------------------------------
Sub DELETE()

Selection.ClearContents

End Sub

Sub InsertLine()

Selection.EntireRow.Insert

End Sub
------------------------------------------------
Sub ZoomUp()

If ActiveWindow.Zoom < 396 Then
ActiveWindow.Zoom = ActiveWindow.Zoom + 5
End If

End Sub
------------------------------------------------
Sub ZoomDown()

If ActiveWindow.Zoom > 30 Then
ActiveWindow.Zoom = ActiveWindow.Zoom - 5
End If

End Sub
------------------------------------------------
Sub charaBIG()
With Selection.Font
.Size = .Size + 1
If .Size > 300 Then
.Size = 300
End If
End With
End Sub
------------------------------------------------
Sub charaSMALL()
With Selection.Font
If .Size >= 2 Then
.Size = .Size - 1
End If
End With
End Sub
------------------------------------------------
Sub LineAutoFit()

nRow = ActiveCell.Row
nCol = ActiveCell.Column
Rows(nRow).Select
Selection.EntireRow.AutoFit
Cells(nRow, nCol).Select

End Sub
------------------------------------------------
Sub ColumnAutoFit()

nRow = ActiveCell.Row
nCol = ActiveCell.Column
Columns(nCol).Select
Selection.EntireColumn.AutoFit
Cells(nRow, nCol).Select

End Sub
D
------------------------------------------------
Sub ウィンドウ最少化()
Application.WindowState = xlMinimized
End Sub
------------------------------------------------
Sub 列幅微増()
Selection.ColumnWidth = Selection.ColumnWidth + 1
End Sub
------------------------------------------------
Sub 列幅微減()
If Selection.ColumnWidth > 1 Then
Selection.ColumnWidth = Selection.ColumnWidth - 1
Else
Selection.ColumnWidth = 0
End If
End Sub
------------------------------------------------
Sub セル縦位置UP()
'
With Selection
If .VerticalAlignment = xlBottom Then
.VerticalAlignment = xlCenter
Exit Sub
End If
If .VerticalAlignment = xlCenter Then
.VerticalAlignment = xlTop
Exit Sub
End If
.VerticalAlignment = xlTop
End With
'
End Sub
------------------------------------------------
Sub セル縦位置DOWN()
'
With Selection
If .VerticalAlignment = xlTop Then
.VerticalAlignment = xlCenter
Exit Sub
End If
If .VerticalAlignment = xlCenter Then
.VerticalAlignment = xlBottom
Exit Sub
End If
.VerticalAlignment = xlBottom
End With
'
End Sub
------------------------------------------------
Sub 列幅折り返し表示()
With Selection
If .WrapText = True Then
.WrapText = False
Else
.WrapText = True
End If
End With
End Sub
------------------------------------------------
Sub 文字左詰め表示()
With Selection
.HorizontalAlignment = xlLeft
End With
End Sub
------------------------------------------------
Sub 文字中央揃い表示()
With Selection
.HorizontalAlignment = xlCenter
End With
End Sub
------------------------------------------------
Sub 文字右詰め表示()
With Selection
.HorizontalAlignment = xlRight
End With
End Sub
------------------------------------------------
Sub Cell結合()
'
With Selection
If .MergeCells = False Then
.MergeCells = True
.HorizontalAlignment = xlCenter
Else
.MergeCells = False
End If
End With
'
End Sub
------------------------------------------------
Sub Next_Sheet_Active() '
Dim sheet_cnt As Long
Dim activesheetname As String
Dim ws As Variant
Dim i As Long

sheet_cnt = ActiveWorkbook.Sheets.Count
activesheetname = ActiveWorkbook.ActiveSheet.Name
For i = 1 To sheet_cnt
If ActiveWorkbook.Sheets(i).Name = activesheetname Then
Exit For
End If
Next

Do
i = i + 1
If i > sheet_cnt Then i = 1
If ActiveWorkbook.Sheets(i).Visible = True Then
ActiveWorkbook.Sheets(i).Select
Exit Do
End If
Loop
'
End Sub
------------------------------------------------
Sub Prior_Sheet_Active() '
Dim sheet_cnt As Long
Dim activesheetname As String
Dim ws As Variant
Dim i As Long

sheet_cnt = ActiveWorkbook.Sheets.Count
activesheetname = ActiveWorkbook.ActiveSheet.Name
For i = 1 To sheet_cnt
If ActiveWorkbook.Sheets(i).Name = activesheetname Then
Exit For
End If
Next

Do
i = i - 1
If i < 1 Then i = sheet_cnt
If ActiveWorkbook.Sheets(i).Visible = True Then
ActiveWorkbook.Sheets(i).Select
Exit Do
End If
Loop
'
End Sub
------------------------------------------------
********キーボードツール_ここまで***************************
------------------------------------------------
Sub ■範囲選択してコピー()
Range("a1").CurrentRegion.Select 'A1を含むひとかたまりを選択
Selection.Copy '上下右空白に囲まれたものを認識している
End Sub
------------------------------------------------
Sub ■Workbook新規作成()
Workbooks.Add
End Sub
------------------------------------------------
Sub ■ウインドウサイズ指定()
Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select '3シート全部
ActiveWindow.Zoom = 75
End Sub
------------------------------------------------
Sub ■workbookの表示場所とサイズ()
ActiveWindow.Top = 250
ActiveWindow.Left = 300
ActiveWindow.Height = 250
ActiveWindow.Width = 650
End Sub
------------------------------------------------
Sub ■列幅調整()
Columns("A").ColumnWidth = 16.63
Columns("E").ColumnWidth = 11
End Sub
------------------------------------------------
Sub ■アクティブシートをコピーして追加する()
ActiveSheet.Copy after:=Sheets(Sheets.Count)
End Sub
------------------------------------------------
Sub ■J列空欄でフィルタし行削除()
Range("A1").AutoFilter field:=10, criteria:=Array(""), Operator:=xlFilterValues
Rows("2:2").Select '(1)2行目を選択
Range(Selection, Selection.End(xlDown)).Select '2行目から連続した最後の行までを選択
Selection.DELETE shift:=xlUp '選択行を削除して上に詰める
Selection.AutoFilter field:=10 'フィルタ解除
End Sub
------------------------------------------------
Sub ■改行マーク削除()
Cells.Replace what:="" & che(10) & "", replacement:="", lookat:=xlPart, seaechorder:=xlByRows, MatchCase:=False, searchformat:=False, ReplaceFormat:=False
End Sub
------------------------------------------------
Sub ■カンマ削除()
Cells.Replace what:=",", replacement:="", lookat:=xlPart, seaechorder:=xlByRows, MatchCase:=False, searchformat:=False, ReplaceFormat:=False
End Sub
------------------------------------------------
Sub ■株_有_置換()
With Range("B:B")
.Replace what:="株）", replacement:="株式会社 "
.Replace what:="有）", replacement:="有限会社 "
.Replace what:="（株", replacement:=" 株式会社"
.Replace what:="（有", replacement:=" 有限会社"
End With
End Sub
------------------------------------------------
Sub ■セル内の一部を検索して空白に置換()
Cells.fing(what:="①").Replace what:="①", replacement:=""
End Sub
------------------------------------------------
Sub ■頭の特定数で始まるもの行削除()
'203と264で始まるもの行削除
Dim i As Long

For i = Range("A1").End(xlDown).Row To 2 Step -1
With Cells(i, 2)

If_
.Value Like "203*" Or_
.Value Like "264*" Then

.EntireRow.DELETE

End If

End With

Next i

End Sub
------------------------------------------------
Sub ■フィルタ()
'「不適合」と付くもの以外、A列から4列目
Range("A1").AutoFilter field:=4, Criteria1:="<>*不適合*"

'「＃N/A」エラーのもの、A列から15列目
Range("A1").AutoFilter field:=15, Criteria1:="#N/A"
End Sub
------------------------------------------------
Sub ■任意のtextファイルを開く()
Shell "notepad D:\○○○\○○フォルダ\○○.txt", vbNormalFocus

End Sub
------------------------------------------------
Sub ■指定ファイルOpen①()
Const path As String = "○○○\○○フォルダ\○○\"
Workbooks.Open path & "○○表.xlsx"

End Sub
------------------------------------------------
Sub ■指定ファイルOpen②()
Workbooks.Open Filename:="アソシエイツ利用.xlsx"

End Sub
------------------------------------------------
Sub ■指定ファイルOpenパスワード付き()
Workbooks.Open "D:\○○○\○○フォルダ\○○表.xlsx", Password:="201605", ReadOnly:=True
'パスワード201605を入力
End Sub
------------------------------------------------
Sub ■指定ファイルOpen選択BOX開く()
Dim OpenFileName As String
OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xlsx")
If OpenFileName <> "False" Then
Workbooks.Open OpenFileName

'ここに走らせる処理を延々書く
'ここに走らせる処理を延々書く
'ここに走らせる処理を延々書く

End If
End Sub
------------------------------------------------
Sub ■ファイル名を2016年付けたものに変更()
setbook1 = Workbooks("○○○2016年.xlsx")

End Sub
------------------------------------------------
Sub ■今日の日付で保存するパスワード外す()
book1.SaveAs Filename:="D:\Users\Documents\○○\◎◎.xlsx"
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False

End Sub
------------------------------------------------
Sub CSV保存()
Application.DisplayAlerts = False

ActiveSheet.SaveAs filename:=D:\Users\○○○\Desktop\○○○csv\ActiveSheet.Name&".csv",Fileformat:=xlCSV,CreateBackup:=False

'ActiveWindow.Close

Application.DisplayAlerts = True

MsgBox "シート名でcsv保存したから、xlsx保存してね", vbYes


End Sub
------------------------------------------------
Sub フォルダを指定してファイル名と最終更新日時の一覧を作成する()
Dim fld As FileDialog

Dim fd_path As String
Dim fl_name As String
Dim i As Long

Set fld = Application.FileDialog(msoFileDialogFolderPicker)
'キャンセル時にマクロ終了
If fld.Show = 0 Then Exit Sub

'フォルダのフルパスを変数に格納
fd_path = fld.SelectedItems(1)

'指定されたフォルダの1つ目のファイル名を取得
fl_name = Dir(fd_path & "\*")
If fl_name = "" Then MsgBox "ファイルが存在しません。": Exit Sub

Worksheets.Add before:=Sheets(1)

Range("A1").Value = fd_path
Range("A2").Value = "のファイル一覧"
Range("A4").Value = "ファイル名"
Range("B4").Value = "最終更新日時"

i = 5
ChDir fd_path & "\" 'カレントフォルダの変更
Do Until fl_name = ""
Cells(i, "A").Value = fl_name
Cells(i, "B").Value = FileDateTime(fl_name)
i = i + 1
fl_name = Dir '次のファイル名を取得
Loop

Columns("A:B").ColumnWidth = 18

MsgBox Sheets(1).Name & "に一覧を作成しました。"

End Sub
------------------------------------------------
Sub ■画面遷移を見せない()
Application.ScreenUpdating = False
End Sub
------------------------------------------------
Sub ■画面遷移を見せる()
Application.ScreenUpdating = True
End Sub
------------------------------------------------
Sub ■エラーを無視する｡()
On Error Resume Next
End Sub
------------------------------------------------
Sub ■重複データを削除()
ActiveSheet.Range("A:B").removeduplicayes Columns:=Array(1, 2, 3, 4), _
Header:=xlYes
End Sub
------------------------------------------------
Sub ■C列を基準に降順で並べ替えます()
'2行目から並べ替えます
Range("A:D").Sort key1:=Range("C2"), Order1:=xlDescending, Header:=xlYes
End Sub
------------------------------------------------
Sub ■ウィンドウを上下に並べる()
Windows.Arrange ArrangeStyle:=xlarrangestylehoraizontal

End Sub
------------------------------------------------
****サンプルをサクッと_ここから*****************************
------------------------------------------------
Sub Sample006()
'セルA1からH100の表で、重複しているデータを削除する
'顧客ID、顧客名、フりガナ、性別、年齢、郵便番号、都道府県、住所
Range("A1:H100").RemoveDuplicates _
Array(1, 2, 3, 4, 5, 6, 7, 8)'A～Hのすべてを検証対象
End Sub
------------------------------------------------
Sub Sample006_3()
'1、2列目だけを条件にして重複かどうかを調べて削除する
　　'顧客ID、顧客名、のみ
Range("A1:H100").RemoveDuplicates Array(1, 2)
End Sub
------------------------------------------------
Sub Sample011()
Dim i As Long '繰り返し処理用の変数
'表の一番下の行から1つめのデータまで処理を繰り返す
'商品コード、商品名、売上日、担当者名、販売数量、単価、合計金額
For i = Range("A1:G100").Rows.Count To 2 Step -1
'「商品コード」が「PP01」かチェックする
If Cells(i, 1).Value = "PP01" Then
'行を削除する
Cells(i, 1).EntireRow.Delete xlUp
End If
Next
End Sub
------------------------------------------------
Sub Sample011_2()
Dim i As Long '繰り返し処理用の変数
'表の一番下の行から1つめのデータまで処理を繰り返す
'商品コード、商品名、売上日、担当者名、販売数量、単価、合計金額
With Range("C5").CurrentRegion　'表がC5から始まる時、C5を含む表
For i = .Rows.Count To 2 Step -1
If .Cells(i, 2).Value = "PP01" Then
.Cells(i, 1).EntireRow.Delete
End If
Next
End With
End Sub
------------------------------------------------
Sub Sample011_3()
Dim i As Long '繰り返し処理用の変数
'表の一番下の行から1つめのデータまで処理を繰り返す
'商品コード、商品名、売上日、担当者名、販売数量、単価、合計金額、、、商品コード、商品名
'右に別表ある場合
For i = Range("A1:G100").Rows.Count To 2 Step -1
'「商品コード」が「PP01」かチェックする
If Cells(i, 1).Value = "PP01" Then
'行を削除する
Range("A1:G100").Rows(i).Delete xlShiftUp
End If
Next
End Sub
------------------------------------------------
****サンプルをサクッと_ここまで*****************************
------------------------------------------------




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

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

●課題0702●

 

●課題0702●

<a href="http://blog-imgs-50.fc2.com/a/d/r/adrenalin2/20141025101112f23.png" target="_blank"><img src="http://blog-imgs-50.fc2.com/a/d/r/adrenalin2/20141025101112f23.png" alt="課0702" border="0" width="960" height="552" /></a>

D列の得点が80点以上ならE列に「A」、65点以上なら「B」、それ以外なら「C」を、E5～E14に表示させる。

 

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

Sub Module1

 

 Public Sub 課題0702()

　　Dim 得点 As Integer

　　Dim a As Integer

    

　　For a = 5 To 14 Step 1

    

　　　得点 = Cells(a, 4).Value

    

　　　If 得点 >= 80 Then

    

　　　　Cells(a, 5).Value = "A"

        

　　　ElseIf 得点 >= 65 Then

    

　　　　Cells(a, 5).Value = "B"

        

　　　Else

            

　　　　Cells(a, 5).Value = "C"

            

　　　End If

    

　　Next a

     　

　End Sub

 

End Sub

 

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

 

 

●練習0803●

<a href="http://blog-imgs-50.fc2.com/a/d/r/adrenalin2/20141025104324be3.png" target="_blank"><img src="http://blog-imgs-50.fc2.com/a/d/r/adrenalin2/20141025104324be3.png" alt="練習0803" border="0" width="315" height="271" /></a>

セルE3にセルC3に入力されている住所の中から「東京都」という文字列を取り出して表示させる

セルF3にセルC3に入力されている住所の中から「東京都」を除いた「○○市」という部分だけを抽出し表示させる

セルE3とセルF3to同様に16行目までE列の「都道府県」とF列の「市」を求めてください

 

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

 Attribute VBA_ModuleType=VBAModule

Sub Module1

 Public Sub 練習0803()

　　　　Dim No As Integer

　　　　Dim a As Integer

    

　　　　For a = 3 To 16 Step 1

    

　　　　　住所 = Cells(a, 3).Value

　　　　　Cells(a, 5).Value = Left(住所, 3)

　　　　　No = InStr(住所, "市")

　　　　　Cells(a, 6).Value = Mid(住所, 4, No - 3)

    

　　　Next a

    

　End Sub

End Sub

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

 

 

 

●メソッド●

[ClearContents]

 

Public Sub 課題0105()

　　Range("D4:D10").ClearContents

End Sub

 

指定したオブジェクトのデータを削除します

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

 

Public Sub 練習0103()

　　　　Range("G4").Copy

　　　　Range("C4:C14").PasteSpecial

　　　　Range("A1").Select

 End Sub

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

Public Sub 課題0201()

　　Range("A1").Value = 1

End Sub

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

Public Sub 課題0202()

　　　Range("B2").Font.Size = 20

End Sub

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

Public Sub 課題0203()

　　　Range("B2").Font.Bold = True

　　　Range("B2").Font.Italic = True

End Sub

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

Public Sub 課題0204()

　　　Range("B10:G10").Font.ColorIndex = 3

End Sub

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

Public Sub 課題0205()

　　　Range("B8:E8").Interior.ColorIndex = 6

End Sub

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

Public Sub 練習0201()

　　　Range("C10").Value = "=sum(C4:C9)"

　　　Range("C10").Copy

Range("D10").PasteSpecial

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

 

<a href="http://blog-imgs-50.fc2.com/a/d/r/adrenalin2/20141025113241455.png" target="_blank"><img src="http://blog-imgs-50.fc2.com/a/d/r/adrenalin2/20141025113241455.png" alt="練習0202" border="0" width="401" height="313" /></a>

セルＡ4からセルＡ8をコピーしてセルＡ12とＤ12とＤ12に貼り付けてください

セルＢ4からセルＢ8の「9月」の売上もＥ列とＨ列に貼り付けてください

同様に「10月」「11月」の売上もＥ列とＨ列に貼り付けてください

セルＡ11とＤ11とＧ11に「月別売上」という文字列を挿入してください。

挿入した文字列のフォントサイズを「16ｐｔ」に設定し、「斜体」にしてください

 

Public Sub 練習0202()

　　　Range("A4:A8").Copy

　　　Range("A12,D12,G12").PasteSpecial

　　　Range("B4:B8").Copy

　　　Range("B12").PasteSpecial

　　　Range("C4:C8").Copy

　　　Range("E12").PasteSpecial

　　　Range("D4:D8").Copy

　　　Range("H12").PasteSpecial

　　　Range("A11,D11,G11").Value = "月別売上"

　　　Range("A11,D11,G11").Font.Size = 16

　　　Range("A11,D11,G11").Font.Italic = True

　End Sub

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

 

<a href="http://blog-imgs-50.fc2.com/a/d/r/adrenalin2/2014102511435733d.png" target="_blank"><img src="http://blog-imgs-50.fc2.com/a/d/r/adrenalin2/2014102511435733d.png" alt="練習0203" border="0" width="302" height="256" /></a>

セルＣ3のセルの塗りつぶしの色をセルＢ3に入力されている値に応じた色に変更する。

 

Public Sub 練習0203()

　　　Range("C3").Interior.ColorIndex = Range("B3").Value

  

　End Sub

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

●練習問題0902●

<a href="http://blog-imgs-50.fc2.com/a/d/r/adrenalin2/20141025115419e6b.png" target="_blank"><img src="http://blog-imgs-50.fc2.com/a/d/r/adrenalin2/20141025115419e6b.png" alt="練習0902" border="0" width="452" height="407" /></a>

・プログラムを実行すると「交通安全に関するテストを行います。」というメッセージボックスを表示させてください。

・セルＢ4からセルＢ9に入力されている問題を1問づつ表示されるメッセージボックスを表示させてください。ただし、メッセージボックスには、「はい」「いいえ」の2種類のボタンがあり、ボタンを押した結果がセルＣ4からＣ9に入力されるようにしてください。

・Ｃ列に入力された回答とＤ列の回答が同じ数を数えて得点を求めてください。

・求めた得点に応じた結果が「あなたの得点は、○店です。」というようなメッセージとして表示されるメッセージボックスを表示させてください。

 

Public Sub 練習0902()

Dim a As Integer

     Dim 問題 As String

     Dim 得点 As Integer

 

   

     MsgBox ("交通安全に関するテストを行います。")

     For a = 4 To 8 Step 1

          

       問題 = Cells(a, 2).Value

       Cells(a, 3).Value = MsgBox(問題, vbYesNo)

 

       If Cells(a, 3).Value = Cells(a, 4).Value Then

           得点 = 得点 + 1

   

      End If

     Next a

Rem    

     MsgBox ("あなたの得点は" & 得点 & "点" & "です。")

End Sub

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

●練習1102●

<a href="http://blog-imgs-50.fc2.com/a/d/r/adrenalin2/2014102513293547f.png" target="_blank"><img src="http://blog-imgs-50.fc2.com/a/d/r/adrenalin2/2014102513293547f.png" alt="練習1102" border="0" width="680" height="577" /></a>

 

・ある書店の1月から6月までの売上のデータです。

・売上データを1ヶ月ごとに分けてシートにコピーしてください。コピーするシートは、新しく作成しそれぞれの月をシート名にしてください。

・作成した「1月」シートから「6月」』シートのＡ列からＥ列の列幅を「売上データ」シートのＡ列からＥ列の列幅と同じにしてください。

 

Public Sub 練習1102()

　　Dim 月数 As Integer

　　Dim 条件1 As String

　　Dim 条件2 As String

　　Dim シート数 As Integer

　　Dim シート名 As String

　　Dim 列 As Integer

 

　　 For 月数 = 1 To 6 Step 1

　       

　　　　条件1 = ">=" & DateSerial("2009", 月数, "1")

　　　　条件2 = "<=" & DateSerial("2009", 月数 + 1, "1") - 1

　　　　シート数 = Sheets.Count

　　　　シート名 = 月数 & "月"

　　　　     

　　　　Sheets("売上データ").Select

　　　　　　Range("A1:E292").AutoFilter field:=1, Criteria1:=条件1, Operator:=xlAnd, Criteria2:=条件2

　　　　　　Range("A1:E292").Copy

　　　　　　Sheets.Add after:=Sheets(シート数)

　　　　　　　　　ActiveSheet.Name = シート名

　　　　　　　　　Range("A1").PasteSpecial

　                

　      

　　　　　　 For 列 = 1 To 5 Step 1

　  

　　　　　　Sheets(月数 + 1).Columns(列).ColumnWidth = Sheets("売上データ").Columns(列).ColumnWidth

　    

　　    

　   

　　　　　　Next 列

　      

　　　　　Next 月数

　  

　　End Sub

　

End Sub

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

 

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

　　Sub 合計計算_2()


　　 Range("E14").Select


　　 Do Until ActiveCell.Offset(0,-1).Value = ""


　　 With ActiveCell


　　 .Value =.Offset(0,-2).Value .Offset(0,-1).Value


　　 .Offset(1,0).Select


　　 End With


　　 Loop


　　 End Sub





=INDEX($B$9:$D$15,MATCH(E8,$A$9:$A$15,0),MATCH($G$1,$B$1:$D$1,0))



1.
2.セル
3.
4.
5.
6.
6.
7.
8.
9.
10.

Do-Loop

For-Next


If-Then






重複しているデータ削除（行）
Rem Attribute VBA_ModuleType=VBAModule
Sub Module1
Rem Option Explicit
Rem
Rem Sub Sample006()
Rem '?Z??A1?c?cH100?I?\?A?A?d?!?μ?A?￠?e?f?[?^?d?i???・?e
Rem Range("A1:H100").RemoveDuplicates _
Rem Array(1, 2, 3, 4, 5, 6, 7, 8)
Rem End Sub
Rem
Rem Sub Sample006_2()
Rem '?Z??C10?c?cG200?I?\?A?A?d?!?μ?A?￠?e?f?[?^?d?i???・?e
Rem Range("C10:G200").RemoveDuplicates Array(1, 2, 3, 4, 5)
Rem End Sub
Rem
Rem
Rem Sub Sample006_3()
Rem '1?A2?n?U???￣?d?d???E?μ?A?d?!?c?C???c?d’2?×?A?i???・?e
Rem Range("A1:H100").RemoveDuplicates Array(1, 2)
Rem End Sub


商品コードが「PP01」の行をすべて削除する
Rem Attribute VBA_ModuleType=VBAModule
Sub Module1
Rem Option Explicit
Rem
Rem Sub Sample011()
Rem Dim i As Long '繰り返し処理用の変数
Rem '表の一番下の行から1つめのデータまで処理を繰り返す
Rem For i = Range("A1:G100").Rows.Count To 2 Step -1
Rem '「商品コード」が「PP01」かチェックする
Rem If Cells(i, 1).Value = "PP01" Then
Rem '行を削除する
Rem Cells(i, 1).EntireRow.Delete xlUp
Rem End If
Rem Next
Rem End Sub
Rem
Rem Sub Sample011_2()
Rem Dim i As Long '繰り返し処理用の変数
Rem '表の一番下の行から1つめのデータまで処理を繰り返す
Rem With Range("C5").CurrentRegion
Rem For i = .Rows.Count To 2 Step -1
Rem If .Cells(i, 2).Value = "PP01" Then
Rem .Cells(i, 1).EntireRow.Delete
Rem End If
Rem Next
Rem End With
Rem End Sub
Rem
Rem Sub Sample011_3()
Rem Dim i As Long '繰り返し処理用の変数
Rem '表の一番下の行から1つめのデータまで処理を繰り返す
Rem For i = Range("A1:G100").Rows.Count To 2 Step -1
Rem '「商品コード」が「PP01」かチェックする
Rem If Cells(i, 1).Value = "PP01" Then
Rem '行を削除する
Rem Range("A1:G100").Rows(i).Delete xlShiftUp
Rem End If
Rem Next
Rem End Sub
Rem
End Sub


大量の半角全角の郵便番号を半角に統一
Rem Attribute VBA_ModuleType=VBAModule
Sub Module1
Rem Option Explicit
Rem
Rem Sub Sample013()
Rem Dim Target As Range '処理対象のセルを表す変数
Rem 'セルB2からB100のセル範囲に対して処理を行う
Rem For Each Target In Range("B2:B100")
Rem 'セルの値を半角に変換する
Rem Target.Value = StrConv(Target.Value, vbNarrow)
Rem Next
Rem End Sub
Rem
Rem Sub Sample013_3()
Rem Dim i As Long
Rem Dim temp As String
Rem Dim Data As String
Rem For Each Target In Range("B2:B100")
Rem .文字数分処理を繰り返す
Rem For i = 1 To Len(Target.Value)
Rem temp = Mid(Target.Value, i, 1) '1文字取り出す
Rem .全角かチェックする
Rem If temp Like "[０-９]" Or temp = "－" Then
Rem temp = StrConv(temp, vbNarrow) '半角に変換する
Rem End If
Rem Data = Data & temp '変数Dataに代入する
Rem Next
Rem Target.Value = Data 'セルの値を上書きする
Rem Next
Rem End Sub
End Sub

郵便番号が正しく、桁落ちなどせずにゅうりょくされているかチェックする

Rem Attribute VBA_ModuleType=VBAModule
Sub Module1
Rem Option Explicit
Rem
Rem Sub Sample049()
Rem Dim objCheck As Object
Rem Dim Target As Range
Rem Dim i As Long
Rem
Rem Set objCheck = CreateObject("VBScript.RegExp")
Rem
Rem objCheck.Pattern = "\d{2,4}-\d{2,4}-\d{4}"
Rem
Rem For i = 2 To Range("A1").CurrentRegion.Rows.Count
Rem If objCheck.Test(Cells(i, 7).Value) = False Then
Rem Cells(i, 7).Interior.ColorIndex = 3
Rem End If
Rem Next
Rem
Rem End Sub
Rem
Rem Sub Sample049_2()
Rem Dim objCheck As Object
Rem Dim Target As Range
Rem Dim i As Long
Rem
Rem Set objCheck = CreateObject("VBScript.RegExp")
Rem
Rem objCheck.Pattern = "[0-9]{2,5}[-(][0-9]{1,4}[-)][0-9]{4}"
Rem
Rem For i = 2 To Range("A1").CurrentRegion.Rows.Count
Rem If objCheck.Test(Cells(i, 7).Value) = False Then
Rem Cells(i, 7).Interior.ColorIndex = 3
Rem End If
Rem Next
Rem
Rem End Sub
Rem
Rem Sub Sample049_3()
Rem Dim objCheck As Object
Rem Dim Target As Range
Rem Dim i As Long
Rem
Rem Set objCheck = CreateObject("VBScript.RegExp")
Rem
Rem objCheck.Pattern = "S[A-Z]{3}[0-9]{5}"
Rem
Rem For i = 2 To Range("A1").CurrentRegion.Rows.Count
Rem If objCheck.Test(Cells(i, 7).Value) = False Then
Rem Cells(i, 7).Interior.ColorIndex = 3
Rem End If
Rem Next
Rem
Rem End Sub
End Sub


=INDEX($B$9:$D$15,MATCH(E8,$A$9:$A$15,0),MATCH($G$1,$B$1:$D$1,0))






100MB無料ホームページ│ 可愛いサーバロリポップClick Here!