Top> 部品データベース
最後の行を取り出す
lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
元帳空白処理
元帳伝票日付の最後が最終伝票と判断
lastrow = Worksheets("元帳").Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To lastrow
For j = 1 To 6
Worksheets("元帳").Cells(i, j) = ""
Next
Next
特定の列のみクリア
lastrow = Worksheets("地区").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
Worksheets("地区").Cells(i, 3) = ""
Next
並び替え（範囲が決まっている場合）
Worksheets("作業").Activate
Range(Cells(2, 1), Cells(j - 1, 6)).Select
ActiveWorkbook.Worksheets("作業").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("作業").Sort.SortFields.Add Key:=Cells(2, 1), SortOn _
:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("作業").Sort
.SetRange Range(Cells(2, 1), Cells(j - 1, 6))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
並び替え（件数から範囲を判断する場合）
Worksheets("地区件数作業１").Activate
lastrow = Worksheets("地区件数作業１").Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(2, 1), Cells(lastrow, 2)).Select
ActiveWorkbook.Worksheets("地区件数作業１").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("地区件数作業１").Sort.SortFields.Add Key:=Cells(2, 1), SortOn _
:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("地区件数作業１").Sort
.SetRange Range(Cells(2, 1), Cells(lastrow, 2))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
並び替え（２つのキーの場合）
Sub Macro4()
ActiveWorkbook.Worksheets("データ").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("データ").Sort.SortFields.Add Key:=Range("A2:A5"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("データ").Sort.SortFields.Add Key:=Range("B2:B5"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("データ").Sort
.SetRange Range("A1:C5")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
セルを使った例
Worksheets("分類集計").Activate
ActiveWorkbook.Worksheets("分類集計").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("分類集計").Sort.SortFields.Add Key:=Cells(2, 1), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("分類集計").Sort.SortFields.Add Key:=Cells(2, 2), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("分類集計").Sort
.SetRange Range(Cells(2, 1), Cells(lastRow, 3))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
分類計の取り方
Dim lastRow As Long
Dim i As Long
Dim j As Long
Dim kei As Long
'分類作業空白処理
lastRow = Worksheets("分類作業").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
For j = 1 To 2
Worksheets("分類作業").Cells(i, j) = ""
Next
Next
'分類の最後の行No取得
lastRow = Worksheets("分類").Cells(Rows.Count, 1).End(xlUp).Row
j = 2
kei = 0
For i = 2 To lastRow
'合計計算
kei = kei + Worksheets("分類").Cells(i, 2)
If Worksheets("分類").Cells(i, 1) <> Worksheets("分類").Cells(i + 1, 1) Then
Worksheets("分類作業").Cells(j, 1) = Worksheets("分類").Cells(i, 1)
Worksheets("分類作業").Cells(j, 2) = kei
j = j + 1
kei = 0
End If
Next
Worksheets("分類作業").Activate
小計の取り方（配列からエクセルシートへ）
i = 5
tukikeir = 0
tukikeis = 0
For j = 0 To hairetu - 1
Worksheets("元帳").Cells(i, 2) = datah(j, 0)
Worksheets("元帳").Cells(i, 4) = datah(j, 1)
Worksheets("元帳").Cells(i, 6) = datah(j, 2)
Worksheets("元帳").Cells(i, 17) = datah(j, 3)
Worksheets("元帳").Cells(i, 22) = datah(j, 4)
Worksheets("元帳").Cells(i, 27) = datah(j, 5)
tukikeir = tukikeir + datah(j, 3)
tukikeis = tukikeis + datah(j, 4)
If datah(j, 0) <> datah(j + 1, 0) Then
i = i + 1
Worksheets("元帳").Cells(i, 6) = "<" & datah(j, 0) & "月" & "小計" & ">"
Worksheets("元帳").Cells(i, 17) = Format(tukikeir, "#,###")
Worksheets("元帳").Cells(i, 22) = Format(tukikeis, "#,###")
tukikeir = 0
tukikeis = 0
End If
i = i + 1
Next
科目コードから科目名を取り出す関数
Function kamokukensakuf(kcode As Long) As String
Dim lastRow As Long
Dim i As Long
lastRow = Worksheets("科目表").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
If kcode = Worksheets("科目表").Cells(i, 1) Then
kamokukensakuf = Worksheets("科目表").Cells(i, 2)
Exit Function
End If
Next
kamokukensakuf = ""
MsgBox "科目コードがみつかりません"
End Function
科目名から科目コードを取り出す関数
Function codekensakuf(kname As String) As Long
Dim lastRow As Long
Dim i As Long
lastRow = Worksheets("科目表").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
If kname = Worksheets("科目表").Cells(i, 2) Then
codekensakuf = Worksheets("科目表").Cells(i, 1)
Exit Function
End If
Next
codekensakuf = 0
End Function
商品名から商品コードを取り出す関数
stanka = skensakuf(hinmei, wp, hp)
Function skensakuf(sname As String, wp As String, hp As String) As Long
Dim lastRow As Long
Dim i As Long
lastRow = Worksheets("商品本体").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
If sname = Worksheets("商品本体").Cells(i, 2) Then
If wp = "F" Or hp = "G" Then
skensakuf = 0
Else
skensakuf = Worksheets("商品本体").Cells(i, 3)
End If
frmmitumori.lbltanka.Caption = skensakuf
frmmitumori.lblscode.Caption = Worksheets("商品本体").Cells(i, 1)
Exit Function
End If
Next
MsgBox "商品はみつかりません"
skensakuf = 0
End Function
ボタンによる別シートからのマスター名の移行
Sub 得意先区分名移行()
Dim i As Long
Dim j As Long
Dim lastrow As Long
Dim lastrow1 As Long
lastrow = Worksheets("得意先").Cells(Rows.Count, 1).End(xlUp).Row
lastrow1 = Worksheets("得意先区分").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
For j = 2 To lastrow1
If Cells(i, 5) = Worksheets("得意先区分").Cells(j, 1) Then
Cells(i, 6) = Worksheets("得意先区分").Cells(j, 2)
Exit For
End If
Next
Next
End Sub
VlookUp関数の改良
Function mylookup(kensa, hani, retu)
On Error GoTo エラー処理
mylookup = WorksheetFunction.VLookup(kensa, hani, retu, False)
Exit Function
エラー処理:
If kensa <> "" Then
MsgBox "番号が登録されていません"
End If
mylookup = ""
End Function
アクセスのテーブルのレコード件数の表示
Sub datakensu()
Dim db As ADODB.Connection
Dim rs As ADODB.Recordset
'アクセスのACCDBファイルに接続します
Set db = New ADODB.Connection
db.Provider = "Microsoft.Ace.OLEDB.12.0"
db.Open "D:\教材\VBA\excelvba.accdb"
'レコードセットを開きます
Set rs = New ADODB.Recordset
rs.Open "data", db, adOpenStatic
'レコード数の取得
If rs.RecordCount = 0 Then
MsgBox "レコードが見つかりません。"
Else
MsgBox rs.RecordCount & " 件のレコードが登録されています。(ACCDB)"
End If
rs.Close
Set rs = Nothing
Set db = Nothing
End Sub
アクセスのテーブルの全データ表示
Sub datahyouji()
Dim db As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strSQL As String
'アクセスのACCDBファイルに接続します
Set db = New ADODB.Connection
db.Provider = "Microsoft.Ace.OLEDB.12.0"
db.Open "D:\教材\VBA\excelvba.accdb"
'レコードセットを開きます
Set rs = New ADODB.Recordset
'レコード数の取得
strSQL = "SELECT * FROM data"
rs.Open strSQL, db, adOpenKeyset, adLockReadOnly
Rows("2:65536").ClearContents
' レコードセットからまとめて転記する
Range("A2").CopyFromRecordset rs
'レコードセット、データベースを閉じる
rs.Close
Set rs = Nothing
Set db = Nothing
End Sub
アクセスのテーブルのフィールド指定の表示
Sub datahyoujikoumoku()
Dim db As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strSQL As String
Dim GYO As Long
Dim dbCols As ADODB.Fields
'アクセスのACCDBファイルに接続します
Set db = New ADODB.Connection
db.Provider = "Microsoft.Ace.OLEDB.12.0"
db.Open "D:\教材\VBA\excelvba.accdb"
'レコードセットを開きます
Set rs = New ADODB.Recordset
'レコード数の取得
strSQL = "SELECT * FROM data"
rs.Open strSQL, db, adOpenKeyset, adLockReadOnly
GYO = 1
Rows("2:65536").ClearContents
'' 先頭レコードからEOFまで繰り返す
rs.MoveFirst ' ←この行はなくても問題なし
Do Until rs.EOF
' 行の変数を加算し必要項目を選択してセルにセット
GYO = GYO + 1
Set dbCols = rs.Fields
Cells(GYO, 1).Value = dbCols("namae").Value
Cells(GYO, 2).Value = dbCols("su").Value
' 次のレコードに移る
rs.MoveNext
Loop
' レコードセット、データベースを閉じる
rs.Close
Set rs = Nothing
Set db = Nothing
End Sub
アクセスのテーブルの条件指定の表示
Sub datahyoujijyouken()
Dim db As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strSQL As String
'アクセスのACCDBファイルに接続します
Set db = New ADODB.Connection
db.Provider = "Microsoft.Ace.OLEDB.12.0"
db.Open "D:\教材\VBA\excelvba.accdb"
'レコードセットを開きます
Set rs = New ADODB.Recordset
'レコード数の取得
strSQL = "SELECT * FROM data where bunrui=" & """" & "A" & """"
rs.Open strSQL, db, adOpenKeyset, adLockReadOnly
Rows("2:65536").ClearContents
' レコードセットからまとめて転記する
Range("A2").CopyFromRecordset rs
'レコードセット、データベースを閉じる
rs.Close
Set rs = Nothing
Set db = Nothing
End Sub
文字列の置き換え
エクセルの関数は=SUBSTITUTE(A1,"田中","鈴木")
6行1列目から１０行目までの田中X郎を鈴木X郎に変換
Sub henkan()
Dim i As Long
For i = 6 To 10
Cells(i, 1) = Replace(Cells(i, 1), "田中", "鈴木")
Next
End Sub
抽出
Sub 抽出部品()
Dim i As Long
For i = 2 To 23
If Cells(i, 3) = "タナカタロウ" Then
MsgBox Cells(i, 2)
Exit Sub
End If
Next
End Sub
抽出（フィルター）
With Worksheets("名簿").Range("C3")
.AutoFilter Field:=3, Criteria1:="=ア*" 'オートフィルタで抽出
End With
抽出（クリア）
With Worksheets("名簿").Range("C3")
.AutoFilter 'オートフィルタのクリア
End With
抽出条件を入力するフィルター
Dim seibetu As String
seibetu = InputBox("抽出する性別を入力してください")
'シートのコピー
Worksheets("データベース").Copy after:=Worksheets("メニュー")
'抽出 (フィルター)
Range("D1").AutoFilter Field:=4, Criteria1:="=" & seibetu
あ行カ行の表示
Sub akensaku()
Call kensaku("ア", "カ")
End Sub
Sub kkensaku()
Call kensaku("カ", "サ")
End Sub
Sub kensaku(moji1 As String, moji2 As String)
With Worksheets("名簿").Range("C3")
.AutoFilter Field:=3, Criteria1:=">=" & moji1, Operator:=xlAnd, Criteria2:="<" & moji2
End With
End Sub
表から他の表への転記（コピー）
Worksheets("科目表").Activate
lastrow = Worksheets("科目表").Cells(Rows.Count, 1).End(xlUp).Row
j = 2
For i = 3 To lastrow
Worksheets("作業5").Cells(j, 1) = Worksheets("科目表").Cells(i, 1)
Worksheets("作業5").Cells(j, 2) = Worksheets("科目表").Cells(i, 4)
j = j + 1
Next
表から他の表への転記（条件付き）
Worksheets("科目表").Activate
lastrow = Worksheets("科目表").Cells(Rows.Count, 1).End(xlUp).Row
j = 2
For i = 3 To lastrow
if Worksheets("科目表").Cells(i, 1)=100 then
Worksheets("作業5").Cells(j, 1) = Worksheets("科目表").Cells(i, 1)
Worksheets("作業5").Cells(j, 2) = Worksheets("科目表").Cells(i, 4)
j = j + 1
end if
Next
条件の取り出し（開始から終了のテキストオブジェクト）
Worksheets("売上明細").Activate
lastRow = Worksheets("売上明細").Cells(Rows.Count, 1).End(xlUp).Row
j = 2
For i = 2 To lastRow
If Worksheets("売上明細").Cells(i, 1) >= txtKaisi.Text And Worksheets("売上明細").Cells(i, 1) <= txtEnd.Text Then
Worksheets("作業１").Cells(j, 1) = Worksheets("売上明細").Cells(i, 2)
Worksheets("作業１").Cells(j, 2) = Worksheets("売上明細").Cells(i, 4)
j = j + 1
End If
Next
同じデータを集約（合計）した別の表を作成
Sub sakusei()
Dim i As Long
Dim j As Long
Dim kei As Long
j = 2
kei = 0
For i = 2 To 10
kei = kei + Worksheets("元").Cells(i, 2)
If Worksheets("元").Cells(i, 1) <> Worksheets("元").Cells(i + 1, 1) Then
Worksheets("合計").Cells(j, 1) = Worksheets("元").Cells(i, 1)
Worksheets("合計").Cells(j, 2) = kei
j = j + 1
kei = 0
End If
Next
End Sub
同じデータを2項目集約（合計）した別の表を作成
k = 2
kei = 0
For i = 2 To j - 1
kei = kei + Worksheets("浅井俊行作業").Cells(i, 4)
If Worksheets("浅井俊行作業").Cells(i, 2) <> Worksheets("浅井俊行作業").Cells(i + 1, 2) Or Worksheets("浅井俊行作業").Cells(i, 3) <> Worksheets("浅井俊行作業").Cells(i + 1, 3) Then
Worksheets("浅井俊行作業1").Cells(k, 1) = Worksheets("浅井俊行作業").Cells(i, 2)
Worksheets("浅井俊行作業1").Cells(k, 2) = Worksheets("浅井俊行作業").Cells(i, 3)
Worksheets("浅井俊行作業1").Cells(k, 3) = kei
k = k + 1
kei = 0
End If
Next
表の項目(条件)を他の表に更新する（リレーション）
作業6のデータを作業5から検索して更新する
マスターからトランザクションヘ更新（売上の得意先を売上の得意先コードから検索する）
Dim lastrow As Long
Dim lastrow1 As Long
Dim i As Long
Dim j As Long
Dim tcode As Long
lastrow = Worksheets("売上").Cells(Rows.Count, 1).End(xlUp).Row
lastrow1 = Worksheets("得意先").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
tcode = Worksheets("売上").Cells(i, 2)
For j = 2 To lastrow1
If Worksheets("得意先").Cells(j, 1) = tcode Then
Worksheets("売上").Cells(i, 3) = Worksheets("得意先").Cells(j, 2)
Exit For
End If
Next
Next
合計作業1の金額を科目シートに更新する
Worksheets("合計作業1").Activate
lastrow = Worksheets("合計作業1").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("科目表").Activate
lastrow1 = Worksheets("科目表").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
kcode = Worksheets("合計作業1").Cells(i, 1)
For j = 2 To lastrow1
If Worksheets("科目表").Cells(j, 1) = kcode Then
Worksheets("科目表").Cells(j, 7) = Worksheets("合計作業1").Cells(i, 2)
Exit For
End If
Next
j = 2
Next
合計作業1の金額を科目シートに更新する(改良)
lastrow = Worksheets("作業1").Cells(Rows.Count, 1).End(xlUp).Row
lastrow1 = Worksheets("幼稚園科目名").Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To lastrow
For j = 2 To lastrow1
If Worksheets("幼稚園科目名").Cells(j, 2) = Worksheets("作業1").Cells(i, 1) Then
Worksheets("幼稚園科目名").Cells(j, 3) = Worksheets("作業1").Cells(i, 2)
End If
Next
Next
単一伝票を明細行に追加
lastRow = Worksheets("受注データ").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("受注データ").Cells(lastRow + 1, 1) = Worksheets("受注").Cells(1, 2)
Worksheets("受注データ").Cells(lastRow + 1, 2) = Worksheets("受注").Cells(1, 4)
Worksheets("受注データ").Cells(lastRow + 1, 3) = Worksheets("受注").Cells(2, 4)
行が追加された時の合計計算
Dim i As Long
Dim saigo As Long
saigo = 15
Cells(13, 4) = 0
For i = 2 To saigo
Cells(13, 4) = Cells(13, 4) + Cells(i, 2)
Next
件数
Sub 件数()
Dim lastrow As Long
Dim i As Long
Dim kensu As Long
lastrow = Worksheets("名簿").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Worksheets("名簿").Cells(i, 2) = "大阪市西区" Then
kensu = kensu + 1
End If
Next
MsgBox kensu
End Sub
全ての行列出力
Sub 全ての行列出力()
Dim lastrow As Long
Dim i As Long
Dim j As Long
Worksheets("出力").Cells.Clear
lastrow = Worksheets("データベース").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastrow
For j = 1 To 5
Worksheets("出力").Cells(i, j) = Worksheets("データベース").Cells(i, j)
Next
Next
End Sub
コード変化時の処理
Sub ikou()
Dim i As Long
Dim j As Long
Dim mcode As String
j = 5
mcode = Cells(2, 1)
For i = 2 To 6
If Cells(i, 1) <> mcode Then
j = 10
End If
Cells(j, 5) = Cells(i, 2)
j = j + 1
mcode = Cells(i, 1)
Next
End Sub
シートの統合
Sub keisan()
Dim i As Long
Dim tempData(2) As String
For i = 0 To 2
tempData(i) = Worksheets(i + 2).Name _
& "!" & Worksheets(i + 2).Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)
Next
Worksheets("集計表").Range("A1").Consolidate sources:=tempData(), _
Function:=xlSum, toprow:=True, leftcolumn:=True
End Sub
