覚えておくと便利なコマンド

'***********ワークシートを変更したとき
   Private Sub Worksheet_Change(ByVal Target As Range)
   Select Case Target.Address
   Case "$B$2"
   a = a
   End Select 
   End Sub

'****最終行を取得
      row1 = Range("a1").End(xlDown).Row  'ﾚｺｰﾄﾞの最終行を取得
      col1 = Sheets("sheet1").Range("c3").End(xlToRight).Column  'レコｰドの最右列を取得

'****消去のコマンド   'シート全部を消去するコマンド
    Sheets("Sheet1").Select
    Cells.Select
    Selection.ClearContents
    Selection.Interior.ColorIndex = xlNone

'******色とデータをクリアするマクロ
    Columns("G:H").Select
    Selection.ClearContents
    Selection.Interior.ColorIndex = xlNone


'****印刷範囲の設定のコマンド
    ActiveSheet.PageSetup.PrintArea = "$B$4:$Y$" & row1    'これは印刷範囲の設定
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True  'これは印刷のコマンド


'*****セルの中の色をつけるコマンド
      Cells(p, 7).Select   '指定するセルやその範囲を設定して
      With Selection.Interior   'with文で記載をする
          .ColorIndex = 19      'これはカラーの指定
          .Pattern = xlSolid
          .PatternColorIndex = xlAutomatic
      End With

'JANのチェックデジットを計算するモジュール
Sub plcdchek()   'モジュラス10/ウエィト3方式
  PLCD = CELLS(1,1)'仮にワークシートのRANGE("A1")にPLUコードが入っているとすると
  a = (CLng(Mid(plcd, 2, 1)) + CLng(Mid(plcd, 4, 1)) + CLng(Mid(plcd, 6, 1)) + CLng(Mid(plcd, 8, 1)) + CLng(Mid(plcd, 10, 1)) + CLng(Mid(plcd, 12, 1))) * 3
  b = CLng(Mid(plcd, 1, 1)) + CLng(Mid(plcd, 3, 1)) + CLng(Mid(plcd, 5, 1)) + CLng(Mid(plcd, 7, 1)) + CLng(Mid(plcd, 9, 1)) + CLng(Mid(plcd, 11, 1))
  c = Right(10 - CLng(Right(CStr(a + b), 1)), 1)
chekdig1 = c    '←これがチェックデジットの数
chekdig2 = Mid(plcd, 13, 1)   'PLCDとの違いを確認していくため1桁を出力する

End Sub


'******データを並び替えるマクロ
    row1 = Sheets("sheet1").Range("c4").End(xlDown).Row  'ﾚｺｰﾄﾞの最終行を取得して
    Range("A4:Q" & row1).Select      '次に自社ｺｰﾄﾞ順に並び替えて
    Selection.Sort Key1:=Range("B4"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin

'*******1行を追加するマクロ
       Cells(p, 1).Select
       Selection.EntireRow.Insert    'そして1行追加する


'******** 日数を加算するコマンド
mydate = DateSerial(Mid(KJYMD, 1, 4), Mid(KJYMD, 5, 2), Mid(KJYMD, 7, 2))
IntervalType = "d"        ' "d" によって追加する時間間隔として、日を指定します。
nxtkjymd = Mid(DateAdd("d", 7, mydate), 1, 4) & Mid(DateAdd("d", 7, mydate), 6, 2) & Mid(DateAdd("d", 7, mydate), 9, 2)

'********改行するvbkey  '使用例
    szMess = szMess & "GEKG" & vbCrLf'←これ


'********インプットボックスと、メッセージボックスの使用例
ptencd = InputBox("店舗コードをいれてください")
MsgBox ptencd, , "店舗コード"
KJYMD = InputBox("計上年月日をいれてください")
MsgBox KJYMD, , "計上年月日"


''****簡単なファンクションのテスト1
'文字列編
Sub test()
a = myfunc(aa)
End Sub

Function myfunc(ByVal ass As String)
myfunc = "aaaa" & "っっっb"
End Function


'****簡単なファンクションのテスト
'数値編
'ここでは引数を渡してそれに演算をして返す関数
Sub test2()
a = myfunc2(1)
End Sub

Function myfunc2(ByVal ass As Integer)
myfunc2 = ass + 1
End Function


'

'*******************コネクションの設定
'ここからはaccessからオラクルへの接続の分なので、変数宣言の分から分けておく(判らなくなるから)

Dim cn  'コネクションの設定宣言
Dim rs    'レコード設定の宣言
Dim selcmd   'データを抽出するSQLステートメント

'接続 db名 c:\sa\****.mdbがパス名   'この接続はアクセスの接続方法
'接続はｵﾗｸﾙ直接ではなく、ｱｸｾｽのﾘﾝｸﾌｧｲﾙを通じてｵﾗｸﾙに接続をした方が、接続設定は楽だが・・・

Set cn = CreateObject("ADODB.Connection")

cnst = "provider=microsoft.jet.oledb.4.0;data source=c:\sa\ogama.mdb"  '大釜の接続

cn.ConnectionString = cnst

'**********************************************************************
cn.Open  '接続宣言  仕入トランザクションファイル

'*******************************************************************************
'この下の分は仕入を集計して計算する

selcmd = "SELECT JUMBO_JSITRZ.DPKB, JUMBO_JSITRZ.DPNO, JUMBO_JSITRZ.SICD, JUMBO_JSITRZ.NHYMD, JUMBO_JSITRZ.KJYMD, JUMBO_JSITRZ.PLCD, JUMBO_JSITRZ.SHNM, JUMBO_JSITRZ.GETN, JUMBO_JSITRZ.GEKG"
selcmd = selcmd & " FROM JUMBO_JSITRZ"
selcmd = selcmd & " WHERE (((JUMBO_JSITRZ.NHYMD)<" & KJYMD & ") AND ((JUMBO_JSITRZ.KJYMD)=" & KJYMD & ")) OR (((JUMBO_JSITRZ.NHYMD)>" & nxtkjymd & ") AND ((JUMBO_JSITRZ.KJYMD)=" & KJYMD & "));"

'*******************************************************************************
'データを取得
Set rs = CreateObject("ADODB.Recordset")
rs.Open selcmd, cn

Do While Not rs.EOF
    nCnt = nCnt + 1
'    If nCnt > 30 Then Exit Do
    Sheets("sheet2").Cells(nCnt, 2) = rs("DPKB")
    Sheets("sheet2").Cells(nCnt, 3) = rs("SINM")
    Sheets("sheet2").Cells(nCnt, 6) = rs("入力伝票枚数")
    rs.MoveNext
Loop

    Sheets("sheet2").Cells(3, 4) = "           検査結果                  "


'レコードセットなどの後処理をする
rs.Close
Set rs = Nothing
Set cn = Nothing




'*************************SQLサーバーの接続テスト
Sub SQL接続テスト()
tncd = Sheets("日付入力").Range("g2")
mchnm = Sheets("日付入力").Range("k2")  'マシンの名前を設定する

Dim cn As ADODB.Connection   'コネクションの宣言
Dim rs As ADODB.Recordset    'レコードセットの宣言
Set cn = New ADODB.Connection   'コネクションのセット
cn.Open "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Password=sa;Initial Catalog=RPOS-SYSTEM;Data Source=" & mchnm & "\SQL_INSTANCE"    'コネクションのオープン
Set rs = New ADODB.Recordset   'レコードセットのセット

selcmd = "SELECT JUMBO_JPLMST.*"

selcmd = selcmd & " FROM JUMBO_JPLMST"

Select Case Sheets("sheet1").Range("c2")
Case Is <> ""
clcd = Sheets("sheet1").Range("c2")
selcmd = selcmd & " WHERE (((JUMBO_JPLMST.CLCD) Like '" & clcd & "%') and (JUMBO_JPLMST.TNCD)=" & tncd & ")"
Case ""
plcd = Sheets("sheet1").Range("b2")
selcmd = selcmd & " WHERE (((JUMBO_JPLMST.PLCD) Like '" & plcd & "%'))"
End Select

selcmd = selcmd & " ORDER BY JUMBO_JPLMST.CLCD, JUMBO_JPLMST.PLCD, JUMBO_JPLMST.TNCD;"


Set rs = New Recordset      '新しいレコードセット
rs.Open selcmd, cn     'そして開く
p = 3    '書き込む行の初期値
rs.MoveFirst    'レコードセットの先頭にいく
Do While Not rs.EOF
    p = p + 1
     Sheets("sheet1").Cells(p, 2) = rs!plcd
     Sheets("sheet1").Cells(p, 3) = rs!clcd
     Sheets("sheet1").Cells(p, 4) = rs!shnm
     Sheets("sheet1").Cells(p, 5) = rs!batn
     Select Case rs!cano
     Case 1
     Sheets("sheet1").Cells(p, 6) = rs!getn1
     Sheets("sheet1").Cells(p, 7) = rs!sicd1
     Case 2
     Sheets("sheet1").Cells(p, 6) = rs!getn2
     Sheets("sheet1").Cells(p, 7) = rs!sicd2
     Case 3
     Sheets("sheet1").Cells(p, 6) = rs!getn3
     Sheets("sheet1").Cells(p, 7) = rs!sicd3
     Case 4
     Sheets("sheet1").Cells(p, 6) = rs!getn4
     Sheets("sheet1").Cells(p, 7) = rs!sicd4
     Case 5
     Sheets("sheet1").Cells(p, 6) = rs!getn5
     Sheets("sheet1").Cells(p, 7) = rs!sicd5
     End Select
     Sheets("sheet1").Cells(p, 8) = rs!irsu
     Sheets("sheet1").Cells(p, 9) = rs!tncd
     
    rs.MoveNext
Loop


rs.Close
cn.Close



'*********行列のコントロールの例
Sub 行列チェック()

'これはちょっと難しい課題でした・・・

   Select Case p
   Case Is <> 4
Select Case p
   Case 44
   a = a
End Select
     Select Case (p - 4) Mod 40  '行の値を40で割った余りが
      Case 0    'ゼロの場合で・・
        Select Case (p - 4) / 40 Mod 2 'それを2で割った余り・・すなわち偶数か奇数かの場合
            Case 0   'すなわち偶数の場合
            i = 0
            Case 1   'すなわち奇数の場合
            i = 10
            p2 = p2 - 40
        End Select
     End Select
   End Select
End Sub





'総合マスターアップのモジュール
Sub 総合マスターup1()
Dim tmpcd As String  '店舗コード
Dim actablenm As String 'アクセスの追加するテーブル名
Dim reccnt As Integer    '登録する週のﾚｺｰﾄﾞの件数をいれておく
tmpcd = Sheets("sheet1").Range("c4")  '店舗コードを設定する

actablenm = "総合マスタ"    'テーブル名はこれ


'それぞれの週ﾃﾞｰﾀのレコード件数を確認しておく
    Sheets("sheet6").Select
    If Range("A2").Value = "" Then
      MsgBox "ﾚｺｰﾄﾞがありません"
      Exit Sub
    Else
      reccnt = Range("a1").End(xlDown).Row  'ﾚｺｰﾄﾞの最終行を取得
      reccnt = reccnt  '- 1      これ引く1がレコード数だが､2行からスタートするのでそのまま
    End If
    
    

'ここからはaccessへの追加の分なので、変数宣言の分から分けておく(判らなくなるから)

Dim cn As Connection  'コネクションの設定宣言
Dim rs As Recordset   'レコード設定の宣言

'接続 db名 c:\FB\総合マスタ.mdbがパス名
Set cn = New Connection
Select Case tmpcd
Case 1001  '大釜店
cn.ConnectionString = "provider=microsoft.jet.oledb.4.0;data source=\\monkey\d\FB\総合マスタ.mdb"
Case 1002  '金ヶ崎店
cn.ConnectionString = "provider=microsoft.jet.oledb.4.0;data source=\\bird\d\FB\総合マスタ.mdb"
Case 1003  '津志田店
'cn.ConnectionString = "provider=microsoft.jet.oledb.4.0;data source=\\bird\d\FB\総合マスタ.mdb"
cn.ConnectionString = "provider=microsoft.jet.oledb.4.0;data source=c:\FB\総合マスタ.mdb"
End Select

cn.Open  '接続宣言

'各店週ﾃﾞｰﾀテーブルからデータを取得
Set rs = New Recordset
rs.Open actablenm, cn, adOpenKeyset, adLockOptimistic


'追加する件数をﾙｰﾌﾟする
For i = 2 To reccnt
'データ追加
rs.AddNew
rs!フィールド1 = Cells(i, 1).Value
rs!総合コード = Cells(i, 2).Value
rs!銀行cd4 = Cells(i, 3).Value
rs!銀行名 = Cells(i, 4).Value
rs!カナギンコウ15 = Cells(i, 5).Value
rs!支店cd7 = Cells(i, 6).Value
rs!支店番号3 = Cells(i, 7).Value
rs!支店名 = Cells(i, 8).Value
rs!カナシテン15 = Cells(i, 9).Value
rs!種別 = Cells(i, 10).Value
rs!口座No = Cells(i, 11).Value
rs!口座No先頭1普通2当座8 = Cells(i, 12).Value
rs!口座名義30 = Cells(i, 13).Value
rs!口座漢字名義名30 = Cells(i, 14).Value
rs!その他の内容 = Cells(i, 15).Value
rs!グループ分け = Cells(i, 16).Value
rs!区分1 = Cells(i, 17).Value
rs!区分2 = Cells(i, 18).Value
rs!振込手数料 = Cells(i, 19).Value
rs!手数料仮払消費税 = Cells(i, 20).Value
rs!受取手数料 = Cells(i, 21).Value
rs!受取手数消費税 = Cells(i, 22).Value
rs!他1 = Cells(i, 23).Value
rs!テナントコード = Cells(i, 24).Value
rs!旧台帳銀行名 = Cells(i, 25).Value
rs!率 = Cells(i, 26).Value
rs!住所 = Cells(i, 27).Value
rs!電話番号 = Cells(i, 28).Value
rs!店舗名 = Cells(i, 29).Value
rs!分類コード = Cells(i, 30).Value
rs!分類名 = Cells(i, 31).Value
rs!取り扱い品 = Cells(i, 32).Value
rs!分類コード2 = Cells(i, 33).Value
rs!形態 = Cells(i, 34).Value
rs!大 = Cells(i, 35).Value
rs!金 = Cells(i, 36).Value
rs!フィールド37 = Cells(i, 37).Value

rs.Update  'これらをアップデートする !

Next i

MsgBox actablenm & "  " & reccnt & " 件のﾚｺｰﾄﾞを追加しやんすた !"  '一応確認の意味でのﾒｯｾｰｼﾞ(何の意味もないが)



'レコードセットなどの後処理をする
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing




End Sub




'*******総合マスター削除のモジュール
Sub 総合マスター削除()
Dim tmpcd As String  '店舗コード
Dim actablenm As String 'アクセスの追加するテーブル名
Dim reccnt As Integer    '登録する週のﾚｺｰﾄﾞの件数をいれておく
tmpcd = Sheets("sheet1").Range("c4")  '店舗コードを設定する

actablenm = "総合マスタ"    'テーブル名はこれ


'それぞれの週ﾃﾞｰﾀのレコード件数を確認しておく
    Sheets("sheet6").Select
    If Range("A2").Value = "" Then
      MsgBox "ﾚｺｰﾄﾞがありません"
      Exit Sub
    Else
      reccnt = Range("a1").End(xlDown).Row  'ﾚｺｰﾄﾞの最終行を取得
      reccnt = reccnt  '- 1      これ引く1がレコード数だが､2行からスタートするのでそのまま
    End If

'ここからはaccessへの追加の分なので、変数宣言の分から分けておく(判らなくなるから)

Dim cn As Connection  'コネクションの設定宣言
Dim rs As Recordset   'レコード設定の宣言

'接続 db名 c:\FB\総合マスタ.mdbがパス名
Set cn = New Connection
Select Case tmpcd
Case 1001  '大釜店
cn.ConnectionString = "provider=microsoft.jet.oledb.4.0;data source=\\monkey\d\FB\総合マスタ.mdb"
Case 1002  '金ヶ崎店
cn.ConnectionString = "provider=microsoft.jet.oledb.4.0;data source=\\bird\d\FB\総合マスタ.mdb"
Case 1003  '津志田店
'cn.ConnectionString = "provider=microsoft.jet.oledb.4.0;data source=\\bird\d\FB\総合マスタ.mdb"
cn.ConnectionString = "provider=microsoft.jet.oledb.4.0;data source=c:\FB\総合マスタ.mdb"
End Select


cn.Open  '接続宣言

'各店週ﾃﾞｰﾀテーブルからデータを取得
Set rs = New Recordset
rs.Open actablenm, cn, adOpenKeyset, adLockOptimistic


'削除
ret = MsgBox("一旦すべてのレコードを削除ステ、現状のデータを書込むけど、ほんとにいいんだぇんが？", vbYesNo + vbQuestion, "削除")


  Select Case ret
   Case vbYes
     Do Until rs.EOF
      rs.Delete
      rs.MoveNext
    Loop
   
   Case vbNo
     Exit Sub
  
  End Select



MsgBox actablenm & "  " & reccnt & " 件のﾚｺｰﾄﾞを削除しやんすた !"  '一応確認の意味でのﾒｯｾｰｼﾞ(何の意味もないが)



'レコードセットなどの後処理をする
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing



'*******ファイルの保存とstrconvの使用例
Dim at As String
Dim bt As String
Dim mypath As String
Dim enfil As Integer
enfil = 1
    Sheets("sheet2").Select
mstfilnm = "ZMA001.dat"
    Range("a1") = mstfilnm
    Call メニュー書込
'書き出すファイル名
 A = Application.Path
 mypath = ThisWorkbook.Path & "\"
' mypath = "P:\ebk\FBWin001\"
  Open mypath & mstfilnm For Input As #1
  Do Until EOF(1)
  Select Case enfil
  Case 1
  Input #1, at
    Cells(1 + enfil, 2) = at
                 ai = StrConv(at, vbFromUnicode)
                 ai2 = Mid(ai, 1, 17)
                 ai2 = StrConv(ai2, vbUnicode)
                 Cells(1 + enfil, 3) = ai2
                 
                 ai2 = Mid(ai, 18, 3)
                 ai2 = StrConv(ai2, vbUnicode)
                 Cells(1 + enfil, 4) = ai2

                 ai2 = Mid(ai, 21, 3)
                 ai2 = StrConv(ai2, vbUnicode)
                 Cells(1 + enfil, 5) = ai2
                 
                 ai2 = Mid(ai, 24, 1255)
                 ai2 = StrConv(ai2, vbUnicode)
                 Cells(1 + enfil, 6) = ai2 & "   "

  enfil = enfil + 1
  
  Case 2
  Input #1, at
    Cells(1 + enfil, 2) = at
  enfil = enfil + 1
  
  Case Else
  Input #1, at
    Cells(1 + enfil, 2) = at
        Cells(1 + enfil, 3) = CStr(Mid(at, 1, 5))
            If Cells(1 + enfil, 3) = "" Then
               Cells(1 + enfil, 3) = "     "
            End If
        Cells(1 + enfil, 4) = CStr(Mid(at, 6, 11))
            If Cells(1 + enfil, 4) = "" Then
               Cells(1 + enfil, 4) = "           "
            End If
        Cells(1 + enfil, 5) = CStr(Mid(at, 17, 4))
            If Cells(1 + enfil, 5) = "" Then
               Cells(1 + enfil, 5) = "    "
            End If
        Cells(1 + enfil, 6) = CStr(Mid(at, 21, 15))
            If Cells(1 + enfil, 6) = "" Then
               Cells(1 + enfil, 6) = "               "
            End If
        Cells(1 + enfil, 7) = CStr(Mid(at, 36, 3))
            If Cells(1 + enfil, 7) = "" Then
               Cells(1 + enfil, 7) = "   "
            End If
        Cells(1 + enfil, 8) = CStr(Mid(at, 39, 15))
            If Cells(1 + enfil, 8) = "" Then
               Cells(1 + enfil, 8) = "               "
            End If
        Cells(1 + enfil, 9) = CStr(Mid(at, 54, 8))
            If Cells(1 + enfil, 9) = "" Then
               Cells(1 + enfil, 9) = "        "
            End If
        Cells(1 + enfil, 10) = CStr(Mid(at, 62, 30))
            If Cells(1 + enfil, 10) = "" Then
               Cells(1 + enfil, 10) = "                              "
            End If
        Cells(1 + enfil, 11) = CStr(Mid(at, 92, 10))
            If Cells(1 + enfil, 11) = "" Then
               Cells(1 + enfil, 11) = "          "
            End If
        Cells(1 + enfil, 12) = CStr(Mid(at, 102, 10))
            If Cells(1 + enfil, 12) = "" Then
               Cells(1 + enfil, 12) = "          "
            End If
        Cells(1 + enfil, 13) = CStr(Mid(at, 112, 10))
            If Cells(1 + enfil, 13) = "" Then
               Cells(1 + enfil, 13) = "          "
            End If
        Cells(1 + enfil, 14) = CStr(Mid(at, 122, 1))
            If Cells(1 + enfil, 14) = "" Then
               Cells(1 + enfil, 14) = " "
            End If
        Cells(1 + enfil, 15) = CStr(Mid(at, 123, 1))
            If Cells(1 + enfil, 15) = "" Then
               Cells(1 + enfil, 15) = " "
            End If
        Cells(1 + enfil, 16) = CStr(Mid(at, 124, 10))
            If Cells(1 + enfil, 16) = "" Then
               Cells(1 + enfil, 16) = "          "
            End If
            Select Case Range("h2")
            Case "大釜経費"
            Cells(1 + enfil, 16) = "=IF(ISNA(VLOOKUP(I" & 1 + enfil & ",Sheetk!$F$6:$M$200,6,FALSE)),0,VLOOKUP(I" & 1 + enfil & ",Sheetk!$F$6:$M$200,6,FALSE))"
            Case "大釜20日払い"
            Cells(1 + enfil, 16) = "=IF(ISNA(VLOOKUP(I" & 1 + enfil & ",Sheet20!$F$6:$M$200,6,FALSE)),0,VLOOKUP(I" & 1 + enfil & ",Sheet20!$F$6:$M$200,6,FALSE))"
            End Select
        Cells(1 + enfil, 17) = CStr(Mid(at, 134, 20))
            If Cells(1 + enfil, 17) = "" Then
               Cells(1 + enfil, 17) = "                    "
            End If
        Cells(1 + enfil, 18) = CStr(Mid(at, 154, 30))
            If Cells(1 + enfil, 18) = "" Then
               Cells(1 + enfil, 18) = "                              "
            End If
        
  enfil = enfil + 1
  End Select
  Loop
  Close #1