teacup. [ 掲示板 ] [ 掲示板作成 ] [ 有料掲示板 ] [ ブログ ]

 投稿者
  題名
  内容 入力補助 youtubeの<IFRAME>タグが利用可能です。(詳細)
    
 URL
[ ケータイで使う ] [ BBSティッカー ] [ 書込み通知 ] [ 検索 ]


f_フォーム_15-1128

 投稿者:(^・(O_O)・^)  投稿日:2017年11月 1日(水)03時37分1秒
  □プロシージャ
──────────────────────────────────────────────────

Function f_フォーム()

    UserForm1.Label1.Caption = "データ貼り付け先のファイルを選択してください"
    UserForm1.TextBox1 = vData
    Windows.Arrange ArrangeStyle:=xlVertical
    '(左右)xlVertical、(並べる)xlTiled、(上下)xlHorizontal
ActiveWindow.WindowState = xlMaximized
    UserForm1.Show vbModeless

    対象 = InputBox(Prompt:="文字:1行目" & vbCrLf & _
          "文字:2行目", _
          Default:="デフォルト文字")

    '改行: & vbCrLf &
    'タブ: & Chr(9) &

    '●TextBox
    vData_フィル1 = TextBox1.Value
    vData_フィル2 = TextBox2.Value

End Function

Function f_メッセージボックス()

    '●自動的に消えるMsgBox(5秒)
    Dim vMsg As Object
    Set vMsg = CreateObject("wscript.shell")
    vMsg.Popup "本文", 5, "タイトル", vbInformation
    Set vMsg = Nothing

End Function




□フォーム内
──────────────────────────────────────────────────

'■[OK]ボタン
Private Sub CommandButton1_Click()

    Unload Me
    vData_フィル = TextBox1.Value
    Call 処理2

End Sub


'■[キャンセル]ボタン
Private Sub CommandButton2_Click()

    Unload Me
    ActiveWindow.WindowState = xlMaximized
    Application.ScreenUpdating = True
    MsgBox "処理を中断します"

End Sub


'■リストBOX
Private Sub UserForm_Initialize()

ListBox1.RowSource = Range("a1:a10").Address

End Sub
 
 

h_Access_15-1029_2

 投稿者:(^・(O_O)・^)  投稿日:2017年11月 1日(水)03時33分38秒
  ' ■他
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

'●フィルタを解除してすべてのデータを表示
    DoCmd.ShowAllRecords

'●クエリのレコード数

Set oRS = Application.CurrentDb.OpenRecordset("□クエリ名", dbOpenDynaset)
    oRS.MoveLast
    MsgBox oRS.RecordCount & "レコード"

'●フォームでレコード数を表示
    Me.txtTable1.Value = CurrentDb.TableDefs("□テーブル名").RecordCount

'●フィールド数を取得
    Dim myDB As Database
    Dim myTD As TableDef
    Dim myFild As Field

    Set myDB = CurrentDb                    'カレントデータベースを変数に代入
    Set myTD = myDB.TableDefs!□テーブル名  'フィールドを表示するテーブルを変数に代入する
    Set myTD = myDB.TableDefs(vTable)

    MsgBox myTD.Fields.Count & " 個です"    'テーブル内のフィールド数をCountプロパティから取得


'●文字をTEXTで置換

    Dim FSO As Object, buf As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    vPath = "□パス"
    With FSO.GetFile(vPath).OpenAsTextStream(8)
    buf = .ReadAll
    .Close
    End With

    FSO.GetFile(vPath).Delete
    FSO.CreateTextFile vPath

    buf = Replace(buf, "置換前", "置換後")

    With FSO.GetFile(vPath).OpenAsTextStream(8) '1「読み込み用で開く」2「上書き書き込み用で開く」8「追加書き込み用で開く」
    .Write buf
    .Close
    End With

    Set FSO = Nothing



'●文字コード変換(TEXTで操作)

'http://blog.livedoor.jp/akf0/archives/51597069.html

    Dim FSO As Object, vText_all As String
    Dim Stream As New ADODB.Stream

    vPath = "□パス"
    Stream.Open
    Stream.Type = adTypeText
    Stream.Charset = "UTF-8"                                '文字コードを指定

    '読み込み
    Set FSO = CreateObject("Scripting.FileSystemObject")
    With FSO.GetFile(vPath).OpenAsTextStream
        vText_all = .ReadAll
        .Close
    End With
    Stream.WriteText vText_all                              '文字列を出力

    '指定したファイルに保存
    Stream.SaveToFile vPath, adSaveCreateOverWrite
    Stream.Close


'●文字コードをUTF-8に変更(CSVファイル作成時)
http://d.hatena.ne.jp/replication/20091117/1258418243
http://qiita.com/kou_tana77/items/66b14c7649792c9703d8

    '設定
    Dim Stream As New ADODB.Stream
    Stream.Open
    Stream.Type = adTypeText
    Stream.Charset = "UTF-8"                                '文字コードを指定

    '読み込み
    Set FSO = CreateObject("Scripting.FileSystemObject")
    With FSO.GetFile(vPath).OpenAsTextStream
        vText_all = .ReadAll
        .Close
    End With
    Stream.WriteText vText_all                              '文字列を出力

    'BOM無しに設定
        ' バイナリモードにするためにPositionを一度0に戻す(Readするためにはバイナリタイプでないといけない)
        Stream.Position = 0
        Stream.Type = adTypeBinary

        ' Positionを3にしてから読み込むことで最初の3バイト(BOM)をスキップする
        Stream.Position = 3
        Dim bin: bin = Stream.Read()
        Stream.Close

        ' 読み込んだバイナリデータをバイナリデータとしてファイルに出力する
        Stream.Type = adTypeBinary
        Stream.Open
        Stream.Write (bin)

    '指定したファイルに保存
    Stream.SaveToFile vPath, adSaveCreateOverWrite
    Stream.Close



'●別フォームのボタンを実行

    Private Sub コマンド0_Click()
      MsgBox "クリックされました"
    End Sub

    ↓Public Subに変える

    Public Sub コマンド0_Click()
      MsgBox "クリックされました"
    End Sub

    Sub 実行()
      Call Form_フォーム名.コマンド0_Click
    End Sub


'●他のファイルのマクロ呼び出す

    Dim objAccess As Object
    Set objAccess = CreateObject("Access.Application")
    Call objAccess.OpenCurrentDatabase("□パス")

    'マクロの実行
    objAccess.DoCmd.RunMacro "□マクロ名"

    objAccess.CloseCurrentDatabase
    Set objAccess = Nothing


'●テーブルのフィールド名を変更する

    Dim dbs As Database, tbl As TableDef
    Set dbs = CurrentDb
    Set tbl = dbs.TableDefs("□テーブル名")
    tbl.Fields("□列名").Name = "□変更後"
    tbl.Fields.Refresh


    Dim MyDb As Database, MyTable As TableDef
    Set MyDb = CurrentDb
    Set MyTable = MyDb.TableDefs("□テーブル名")
    MyTable.Fields(1).Name = "変更後のフィールド名"
    MyTable.Fields(0).Name = "1列目の変更後のフィールド名"
    MyTable.Fields(1).Name = "2列目の変更後のフィールド名"
    Set MyTable = Nothing
    Set MyDb = Nothing

①②
    '●テーブルのフィールド名を取得

    Dim MyDb As Database, MyTable As TableDef
    Set MyDb = CurrentDb
    Set MyTable = MyDb.TableDefs("□テーブル名")

    Dim C_name(1 To 9) As String
    For i = 1 To 93
         C_name(i) = MyTable.Fields(i).Name
    Next

    Set MyTable = Nothing

    '●テーブルのフィールド名を取得

    Dim MyDb As Database, MyTable As TableDef
    Set MyDb = CurrentDb
    Set MyTable = MyDb.TableDefs("□テーブル名")

    Dim C_name(1 To 9) As String
    For i = 1 To 93
         C_name(i) = MyTable.Fields(i).Name
    Next

    Set MyTable = Nothing


    '●テーブルのフィールド名を変更する
    Set MyTable = MyDb.TableDefs("□テーブル名")

    For i = 1 To 9
        MyTable.Fields(i).Name = "編集中" & i
    Next
    For i = 1 To 9
        MyTable.Fields(i).Name = C_name(i)
    Next

    Set MyDb = Nothing
    Set MyTable = Nothing


    '●CSVファイルのタイトルを読み取る

    'Dim C1, C2
    Open "□CSVパス" For Input As #1
    Input #1, C1, C2
    MsgBox C1     '1列目のタイトル
    MsgBox C2     '2列目のタイトル
    Close #1


    '●テーブルの値を取得
    テキスト型→ ' で括る
    日付/時刻型→ # で括る
    数値型 → 何も括らない

    戻り値 = DlookUp("フィールド名","テーブル/クエリ名","条件")
    vText = DLookup("フィールド名", "テーブル名", "ID='1'")
    vText = DLookup("フィールド名", "テーブル名", "テーブル名='" & vTable & "'")

    vDay = DLookup("更新日", "test", "テーブル='大元子BOM'")
    Forms!フォーム名!("テキスト" & 0).Value = vDay


' ■URL
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

http://makoto-watanabe.main.jp/
http://makoto-watanabe.main.jp/access/accessVBA.htm#start

http://www.geocities.jp/cbc_vbnet/top/nyumon.html


' ■Excel
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

Function 折り返し()

    If ActiveCell.WrapText = True Then
        Selection.WrapText = False
    Else
        Selection.WrapText = True
    End If

End Function


●Msgboxのタブ区切り:Chr(9)
2-14
16-26
28-42
44-58
60-74
 

h_Access_15-1029_1

 投稿者:(^・(O_O)・^)  投稿日:2017年11月 1日(水)03時33分0秒
  15_1029

'■数式
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

IIf([□]=1,"OK","NG")


●置換 (大/小・半/全・平/カナ)

大/半: StrConv(StrConv([□],8),1)
半/小: StrConv(StrConv([□],8),2)

1  : 文字列を大文字に変換
2  : 文字列を小文字に変換
3  : 文字列の先頭の文字を大文字に変換
4  : 半角文字を全角文字に変換
8  : 全角文字を半角文字に変換
16 : ひらがなをカタカナに変換
32 : カタカナをひらがなに変換


●比較
        StrComp([対象1], [対象2], 比較方法])
全/大 : StrComp([□],StrConv(StrConv([□],8),1),0)

比較方法 0:バイナリモードで比較(略すとこちら)
比較方法 1:テキストモードで比較

<クエリ>
TRUE=0、FALSE=1
<マクロ>
TRUE=0、FALSE=1



'■クエリ
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

●テーブル結び付け
FROM vテーブル;

FROM vテーブル1 INNER JOIN vテーブル1 AS vテーブル2 ON [vテーブル1].v列 = [vテーブル2].v列 (1⇔2
FROM vテーブル1 AS vテーブル2 INNER JOIN vテーブル1 ON [vテーブル2].v列 = [vテーブル1].v列 (2⇔1

FROM vテーブル1 INNER JOIN vテーブル2 ON [vテーブル1].v列1 = [vテーブル2].v列2;
FROM vテーブル1 RIGHT JOIN vテーブル2 ON [vテーブル1].v列1 = [vテーブル2].v列2;
FROM vテーブル1 LEFT JOIN vテーブル2 ON [vテーブル1].v列1 = [vテーブル2].v列2;
FROM vテーブル1 LEFT JOIN vテーブル2 ON ([vテーブル1].v列1 = [vテーブル2].v列2) AND ([vテーブル1].v列1 = [vテーブル2].v列2);

●表示列
SELECT [vテーブル].*
SELECT [vテーブル].v列1,[vテーブル].v列2

●条件式
WHERE ((([[vテーブル].v列1) Is Null));
WHERE ((([[vテーブル].v列1) Is Null)) OR ((([vテーブル].v列1)="1"));
HAVING ((([vテーブル].v列1) Is Null))
HAVING (((Count([vテーブル].[v列1]))=1));

●並び替え(左から優先順)
ORDER BY [vテーブル].v列1, [vテーブル].v列2;

●重複削除
SELECT DISTINCT [vテーブル].v列1, [vテーブル].v列2, [vテーブル].v列3
FROM vテーブル;

●テーブル作成
SELECT [vテーブル_元].* INTO vテーブル_作
FROM vテーブル_元;


'■SQL
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

●UNION(複数のTBLを合わせる)



SELECT [列1], [列2]
FROM [tbl_A]

UNION

SELECT [列1], [列2]
FROM [tbl_B]
ORDER BY [列1];


②名前を変更する

SELECT [列a] AS [変更後], [列2]
FROM [tbl_A]

UNION

SELECT [列b] AS [変更後], [列2]
FROM [tbl_B]
ORDER BY [列1];


③重複するレコードを返す

SELECT [列1], [列2]
FROM [tbl_A]

UNION ALL

SELECT [列1], [列2]
FROM [tbl_B]
ORDER BY [列1];


●Switch

並べ替えテクニック
Switch([所属]="企画部",1,[所属]="営業部",2,[所属]="総務部",3)

'■マクロ
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

' ■システム
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

    '●確認メッセージ
    DoCmd.SetWarnings False
    DoCmd.SetWarnings True

    '●エラー
    On Error Resume Next
    On Error GoTo 0

    '●クエリを実行しデータの内容を最新
    Me.Requery
    Forms("□フォーム名").Requery

    '●インジケータを表示

    SysCmd acSysCmdInitMeter, "実行中・・・", 100
    For i = 1 To 100
        'カウントアップ
        SysCmd acSysCmdUpdateMeter, i
    Next
    '消去
    SysCmd acSysCmdClearStatus

    '●Sleepを使う
    #If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    #Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    #End If

    Call Sleep(1000)

    '●
    flg_num_Error = Err.Number

' ■フォーム
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

    vラベル = Forms!インポート!("ラベル" & i).Caption
    vテキスト = Forms!インポート!("テキスト" & i).Value


'●ボックス
    vChk = Forms!□フォーム名!チェック1.Value
    vChk = Forms(□フォーム名_変数)チェック1.Value
    vChk = Me.チェック1.Value
    vChk = Me("チェック" & i).Value

    vLabel = Forms!エクスポート!("ラベル" & i).Caption
    vPath = Forms!インポート!("テキスト" & i).Value


    '●チェックボックスを全て選択と解除
    If Me("チェック0").Value = 0 Then           'チェック:無
        n = 0
    ElseIf Me("チェック0").Value = -1 Then      'チェック:有
        n = -1
    End If
    On Error GoTo エラー処理
    For i = 1 To 9999
            Me("チェック" & i).Value = n
    Next i
    Exit Sub

' ■数式
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

https://morumoru00.wordpress.com/2011/05/07/access-%E5%85%A8%E8%A7%92%E6%96%87%E5%AD%97%E3%82%92%E5%8D%8A%E8%A7%92%E6%96%87%E5%AD%97%E3%81%AB%E5%A4%89%E6%8F%9B%EF%BC%88%E3%82%AF%E3%82%A8%E3%83%AA%E3%80%80strconv%E9%96%A2%E6%95%B0%EF%BC%89/
StrConv(文字列,定数)

定数一覧
1  : 文字列を大文字に変換
2  : 文字列を小文字に変換
3  : 文字列の先頭の文字を大文字に変換
4  : 半角文字を全角文字に変換
8  : 全角文字を半角文字に変換
16 : ひらがなをカタカナに変換
32 : カタカナをひらがなに変換

(小文字、半角): StrConv(StrConv([●],8),2)
(大文字、半角): StrConv(StrConv([●],8),1)

マクロ
true=0、false=-1
クエリ
true=0、false=1

(半角)●: StrConv([●],8)

完全一致比較(一致したら0)
StrComp([フィールド1], "文字", 0)
比較: IIf(StrComp([①a].[①b],[②a].[②b],0)=0,"","差")

IIf(ISNULL([□].[□]),"□Null","□NotNull")
IIf([天気]="晴れ","○",IIf([天気]="曇り","△",IIf([天気]="雨","□")))


str1 = 文字
str2 = StrConv(str1, vbFromUnicode)

myLen = Len(str1)
myLenB = LenB(str2)

If myLen * 2 = myLenB Then
    MsgBox "全角文字だけです"
ElseIf myLen = myLenB Then
    MsgBox "半角文字だけです"
End If




' ■ファイル操作
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

    '●クエリを読み込む
    On Error Resume Next
    DoCmd.OpenTable "□テーブル名"
    DoCmd.OpenQuery "□クエリ名", acViewNormal, acEdit
    On Error GoTo 0

    '●テーブルクリア
    DoCmd.SetWarnings False
    DoCmd.SetWarnings True
    DoCmd.RunSQL "DELETE FROM □テーブル名"
    DoCmd.RunSQL "DELETE FROM □テーブル名 WHERE □列名 = 1000"
    '●削除
    DoCmd.DeleteObject acTable, vTable_先       'テーブル削除
    Application.CurrentDb.QueryDefs.Delete vクエリ 'クエリ削除
    Application.CurrentDb.QueryDefs.Delete "作業用_" & Format(Date, "yyyymmdd")
    '●テーブルを複製
    Application.DoCmd.CopyObject , "複製テーブル", acTable, "元テーブル"

    '●直接SQLを実行
    DoCmd.RunSQL _
        "SELECT □.* □;"
    DoCmd.RunSQL _
        "SELECT [□TBL].C1, [□TBL].C2, [□TBL].C3 " & _
        "INTO □先TBL " & _
        "FROM □TBL " & _
        "WHERE ((([□TBL].CAL1)="□"));"
    '更新クエリ
    DoCmd.RunSQL _
        "UPDATE □テーブル SET [□テーブル].□列1 = Null, [□テーブル].□列2 = Null;"
    '削除クエリ①
    DoCmd.RunSQL _
        "Delete □TBL.C1 " & _
        "FROM □TBL " & _
        "WHERE □TBL Is Null;"
    '削除クエリ②
    vC = "□列名"
    DoCmd.RunSQL _
        "Delete 作業用_" & Format(Date, "yyyymmdd") & "." & vC & " " & _
        "FROM 作業用_" & Format(Date, "yyyymmdd") & " " & _
        "WHERE 作業用_" & Format(Date, "yyyymmdd") & "." & vC & " Is Null;"


    '●選択クエリ作成
    Application.CurrentDb.CreateQueryDef _
    "クエリ名", "SELECT 証券コード, 銘柄名 FROM 株価情報"

    '●テーブル作成
    DoCmd.RunSQL _
    "SELECT [" & vTable & "].* INTO 作業用_" & Format(Date, "yyyymmdd") & " FROM " & vTable & ";"

    '●クエリ作成
    Application.CurrentDb.CreateQueryDef _
    "v作成クエリ名_" & Format(Date, "yyyymmdd"), "SELECT [vTable].v列1, [vTable].v列2, Format([vTable].[日付],""yyyy/mm/dd"") AS vDay FROM vTable;"

    '●開いたクエリを閉じる
    DoCmd.Close acQuery, "□クエリ名"
    (acQuery、acTable、acForm、acMacro、acReport)




' ■インポート・エクスポート
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

    '●インポート
    On Error GoTo 処理の終わり
    vTable = Forms!インポート!("ラベル" & i).Caption
    vPath = Forms!インポート!("テキスト" & i).Value
    ws = "Sheet1!"
   'ws = "Sheet1!A1:D10"

    'CSV以外
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, vTable, vPath, True, ws
    'CSV
    DoCmd.TransferText acImportDelim, "□ インポート定義", vTable, vPath_csv, -1

    '●エクスポート
    DoCmd.TransferText acExportDelim, "□ エクスポート定義", vTable, vPath, True


    '●テーブルの存在確認
    'Dim daoDB As DAO.Database
    'Dim daoTableDef As DAO.TableDef
    Set daoDB = CurrentDb
    flg_table = 0
    For Each daoTableDef In CurrentDb.TableDefs
        If daoTableDef.Name = vTable Then
            flg_table = 1
            Exit For
        End If
    Next

    '●クエリかどうか判断する(テーブルはスルー)
    Dim str_Query As String
    Dim Obj As AccessObject

    vQuery = "□クエリ名"
    For Each Obj In CurrentData.AllQueries
        If Obj.Name = vQuery Then
'            DoCmd.OpenQuery str_Query, acViewNormal, acEdit 'クエリを開く
            Exit For
        End If
    Next


    '●テキストボックスをnullにする
    Dim ctl As Control
    On Error Resume Next
    'このフォーム内のすべてのコントロールを検索
    For Each ctl In Me.Controls
      With ctl
        If .ControlType = acTextBox Then
          'コントロールの種類がテキストボックスなら値をNull(空)に設定
          .Value = Null
        End If
      End With
    Next ctl



    '●ラベルの有無判定

    Dim FormName As String
    Dim LabelName As String
    Dim Frm As Form
    Dim Ctl As Control

    '変数に代入
    FormName = "名前1"
    LabelName = "ラベル1"

    For Each Frm In Forms
        If Frm.Name = FormName Then
            For Each Ctl In Frm.Controls
                If Ctl.Name = LabelName Then
                    Ctl.Caption = "あいうえお"
                    Exit Function
                End If
            Next Ctl
        End If
    Next Frm



' ■ダイアログボックス
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

'●ファイル参照ダイアログボックスのカスタマイズと表示①

Function TestGetFileName()

    Dim vFile   As String
    Dim intResult As Integer

    WizHook.Key = 51488399                              ' WizHook 有効化
    vFile = "*文字*.csv"                              ' 表示ファイルの指定
    intResult = WizHook.GetFileName( _
                    0, "", "□タイトル", "", vFile, "", _
                    "すべてのファイル (*.*)|*.*", _
                    0, 0, 0, True _
                    )
    WizHook.Key = 0                                     ' WizHook 無効化
    vPath = vFile

End Function



'●ファイル参照ダイアログボックスのカスタマイズと表示②

    Dim myFName As Variant
    Dim myPrompt As String

   'ファイル参照ダイアログボックスのカスタマイズと表示
    With Application.FileDialog(msoFileDialogFilePicker)
       'ファイルフィルタの設定
        .Filters.Clear
        .Filters.Add "csvファイル", "*.csv  "
        .Filters.Add "すべてのファイル", "*.*"

        .FilterIndex = 2                                    '初期選択フィルタの設定
        .AllowMultiSelect = False                           '複数ファイル選択の許可
        .Title = "ファイルの選択"                           'タイトルバーの表示文字
        .ButtonName = "OK"                                  'ボタンの表示文字列の設定

        cnt = 0
        If CBool(.Show) Then
            cnt = cnt + 1
            myPrompt = CStr(myFName)
           '選択ファイルのパスの取得
            For Each myFName In .SelectedItems
                myPrompt = myPrompt & vbCrLf & CStr(myFName)
            Next
            myPrompt = Mid$(myPrompt, 3)
        Else 'キャンセル時にはShowメソッドは0(Long型)を返す
            End
        End If
    End With
    MsgBox myPrompt


'●ダイアログボックスでファイルの選択

    'オブジェクト変数にFileDialogオブジェクトを代入
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    dlg.Title = "フォルダを指定してください"                        'タイトル
    dlg.ButtonName = "選択"                                         '実行ボタン名(デフォルトは[OK])
'   dlg.InitialFileName = "c:\"                                     'カレントフォルダ

    'ダイアログボックスを表示
    boolResult = dlg.Show
    If boolResult Then
        vFolder = dlg.SelectedItems(1)
    Else
    End If



 

URL

 投稿者:(^・(O_O)・^)  投稿日:2017年11月 1日(水)03時20分46秒
編集済
  a_システム_17-1101★
http://6404.teacup.com/mutyo/bbs/82

b1_一覧
http://6404.teacup.com/mutyo/bbs/80
http://6404.teacup.com/mutyo/bbs/81

b2_フィルタ
http://6404.teacup.com/mutyo/bbs/79

c1_シート
http://6404.teacup.com/mutyo/bbs/78

c2_ファイル_フォルダ
http://6404.teacup.com/mutyo/bbs/77

e_配列
http://6404.teacup.com/mutyo/bbs/76

f_フォーム
http://6404.teacup.com/mutyo/bbs/86
g_テキストファイル
http://6404.teacup.com/mutyo/bbs/44

h_Access_15-1029
http://6404.teacup.com/mutyo/bbs/84
http://6404.teacup.com/mutyo/bbs/85

p_ピボット
http://6404.teacup.com/mutyo/bbs/43

y_他
http://6404.teacup.com/mutyo/bbs/74
http://6404.teacup.com/mutyo/bbs/75

y_他_15-1225
http://6404.teacup.com/mutyo/bbs/67

z_リセット
http://6404.teacup.com/mutyo/bbs/41

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

ファイル名変更システム
http://6404.teacup.com/mutyo/bbs/65

フォルダ名
http://6404.teacup.com/mutyo/bbs/66

フォルダ一覧をcsvに出力
http://6404.teacup.com/mutyo/bbs/73


VBA セルの条件付き書式を取得する
http://6404.teacup.com/mutyo/bbs/68

VBS
http://6404.teacup.com/mutyo/bbs/69

VBS - ファイルの一括起動
http://6404.teacup.com/mutyo/bbs/72

VBS - フォルダ内のフォルダ一覧を取得する
http://6404.teacup.com/mutyo/bbs/71






AAA
 

a_システム_17-1101★

 投稿者:(^・(O_O)・^)  投稿日:2017年11月 1日(水)03時20分13秒
  a_システム_10**

Function b0_システム()

    '●システム
    Application.ScreenUpdating = False      '画面更新
    Application.DisplayAlerts = False       '確認ダイアログを表示しない (閉じる)
    Application.EnableEvents = False
    Application.Calculation = xlManual
    Application.Calculation = xlAutomatic
    Application.Interactive = False         '一切のキーやマウス操作を制限(Esc無効)
    Application.CutCopyMode = False

    Application.StatusBar = "■□ : ●"

    '●エラー
    On Error Resume Next
    On Error GoTo 0

    Selection.Calculate                     '選択範囲の再計算
    ActiveSheet.Calculate                   'シートの再計算
    Calculate                               'ブック全体の再計算
    Application.Calculation = xlManual      '手動計算
    Application.Calculation = xlAutomatic   '自動計算


End Function

Function a_変数宣言()

    '●変数設定
    '    Public 変数 As <変数型>
    '
    '<変数型>
    '    Byte    : 0~255の整数
    '    Boolean : True or False
    '    Integer : 整数    : -32768~32767
    '    Long    : 整数    : -2147483648~2147483647
    '    Single  : 少数点を含む数値
    '    Double  : "少数点を含む数値
    '少数点を含む数値 ""
    '    Currency: 15桁の整数と4桁の少数部分の数値
    '    Date: 日付と時刻
    'Object:         オブジェクトを参照するデータ型
    '    String  : 文字列  : 0~2GB
    '    Variant : あらゆる種類の値

End Function


Sub auto_open()

    'シート保護のパス
    'PASS = "0824"

End Sub


Function a_画面表示()

    Application.ScreenUpdating = False

    '●シート保護、スクロール固定、シート非表示
    If ActiveSheet.ProtectContents = False Then
        ActiveWindow.DisplayGridlines = False
        ActiveWindow.DisplayHeadings = False
        ActiveSheet.EnableSelection = xlUnlockedCells
        ActiveSheet.Protect UserInterfaceOnly:=True
        ActiveSheet.ScrollArea = Range("A1:K20").Address
        ActiveWindow.DisplayHeadings = False
        On Error Resume Next
        Sheets("UP用").Visible = False
        On Error GoTo 0
'        ActiveWindow.SelectedSheets.Visible = False

    '●シート非保護、スクロール固定解除、シート表示
    ElseIf ActiveSheet.ProtectContents = True Then
        ActiveWindow.DisplayHeadings = True
        ActiveSheet.Unprotect
        ActiveSheet.ScrollArea = ""
        ActiveWindow.DisplayHeadings = True
        On Error Resume Next
        Sheets("□").Visible = True
        On Error GoTo 0
'        ActiveWindow.DisplayGridlines = True
    End If
End Function



Sub System_折返OFF()
    With Cells
        .VerticalAlignment = xlTop
        .WrapText = False
    End With
End Sub

Sub System_折返ON()
    With Cells
        .VerticalAlignment = xlTop
        .WrapText = True
    End With
End Sub


●イミディエイトウィンドウ

    Debug.Print "abc"

    Dim a(3) As String

    a(0) = "りんご"
    a(1) = "みかん"
    a(2) = "梨"

    Debug.Print a(0)
    Debug.Print a(1)
    Debug.Print a(2)
    Debug.Print a(3)


画面最大・戻す
Application.DisplayFullScreen = True
Application.DisplayFullScreen = False


'●Sleepを使うプロシージャで定義する
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
 

b1_一覧_17-1101_2★

 投稿者:(^・(O_O)・^)  投稿日:2017年11月 1日(水)03時19分14秒
  '■セルの調整
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

    '●追加・削除
    Columns(4).Insert Shift:=xlToRight
    Columns(4).Delete Shift:=xlToLeft
Range("A3:D6").EntireRow.Delete

    '●結合
    Range("A1:B3").Merge
    Range("A1:B3").UnMerge
    '●結合判断
    If Cells(i, 1).MergeCells Then
        buf = buf & Cells(i, 1).Address(0, 0) & "-->結合されています" & vbCrLf
    Else
        buf = buf & Cells(i, 1).Address(0, 0) & "-->結合されていません" & vbCrLf
    End If

    '●表示(行・列)
    Rows(5).EntireRow.Hidden = False
    Rows(5).EntireRow.Hidden = True

    '●セルの幅
    Columns("K:Q").EntireColumn.AutoFit
    Columns(vC).EntireColumn.AutoFit
    Range(Cells(2, vC + 3), Cells(R_end, vC + 9)).Columns.AutoFit

    '●列番号
    vC = Mid(Cells(5, 10).Address, 2, 1)


'●罫線
    Range("B1:E5").Borders.LineStyle = xlContinuous
    Range("B1:E5").BorderAround Weight:=xlMedium '外枠を太線



'■画面
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

'●分割
Rows("2").Select
ActiveWindow.FreezePanes = True

'●全画面表示
Application.DisplayFullScreen = True
Application.DisplayFullScreen = False


'■表示形式
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

    '●書式
    Columns(1).NumberFormatLocal = "yyyy/m/d"

    '●日時の設定
    vData = Format(Date, "yyyymmdd")
    vTime = Format(Now, "hhmm")

    '●日付の設定
     If Len(Month(vDate)) = 1 Then
        vMonth = 0 & Month(vDate)
    Else
        vMonth = Month(vDate)
    End If
    If Len(Day(vDate)) = 1 Then
        vDay = 0 & Day(vDate)
    Else
        vDay = Day(vDate)
    End If
    vDate = Year(vDate) & vMonth & vDay

    '書式を変更
    Range(Cells(1, 1), Cells(3, 3)).NumberFormatLocal = "yyyy/m/d"


    '●表示
    '縮小して表示
    Range(Cells(2, 3), Cells(End_row, 3)).ShrinkToFit = True

    '日付の表示:2012/1/1→1/1
    Range(Cells(2, 13), Cells(End_row, 13)).NumberFormatLocal = "m/d"

    '数字の桁数
    Range(Cells(2, vC_在庫日数), Cells(End_row, vC_納品日_3日閉店時在庫)).NumberFormatLocal = "0.00_ "


    '●列番号を英文字に置換

C = Split(Cells(1, 4).Address, "$")(1)

    '配列で設定
    Dim vC(1 To 3) As String
    vC(1) = 1
    vC(2) = 703
    vC(3) = 16384

    '列番号→英文字に置換 (列:4→列:D)
    For i = 1 To 3
        C = vC(i) + 0
        C = Split(Cells(1, C).Address, "$")(1)
    Next



    '●文字→数値★
    R_end = Cells(Rows.Count, 2).End(xlUp).Row
    For i = 2 To R_end
        vCell = Cells(i, 2).Value
        Cells(i, 2).NumberFormatLocal = "G/標準"
        Cells(i, 2).FormulaR1C1 = vCell
    Next



   '●条件付き書式のクリア
    Application.ScreenUpdating = False
    Cells.FormatConditions.Delete
    Application.ScreenUpdating = True

    '●PQ列(空白セルに色)
    Set vCell = Application.ActiveCell
    Range("P4").Select
    Range("P4:Q1048576").FormatConditions.Add Type:=xlExpression, Formula1:="=P4="""""
    With Range("P4").FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.799981688894314
    End With
    vCell.Select
 

b1_一覧_17-1101_1★

 投稿者:(^・(O_O)・^)  投稿日:2017年11月 1日(水)03時18分39秒
  b1_一覧_10**


    'CurrentRegion プロパティで表全体を選択
    Sheets(1).Range("B3").CurrentRegion.Copy Sheets(2).Range("B3")

'■実行時間
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■


Sub 所要時間()
    vTime1 = Time
        作業1を実行する
    vTime2 = Time
    vTime = (vTime2 - vTime1) * 24 * 60 * 60    '所要時間を秒に換算する
    MsgBox vTime1 & " - " & vTime2
End Sub
Private Sub 作業1を実行する()
                                                'ここへマクロを記入
End Sub


Function b1_基本処理()




'■範囲
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

'○変数設定(末尾)

    R_end = Cells(Rows.Count, 1).End(xlUp).Row
    C_end = Cells(1, Columns.Count).End(xlToLeft).Column
    R_end = ActiveCell.SpecialCells(xlLastCell).Row
    C_end = ActiveCell.SpecialCells(xlLastCell).Column

'末尾1
    R_end = Application.WorksheetFunction.Max(R_end_A, R_end_E)

'末尾2
    C_end = Cells(1, Columns.Count).End(xlToLeft).Column
Dim vR(1 To C_end) As Integer
For i = 1 To C_end
     vR(i) = Cells(Rows.Count, i).End(xlUp).Row
Next
R_end = WorksheetFunction.Max(vR)

'末尾3
    For i = 1 To C_end
        R_end1 = Cells(Rows.Count, 1).End(xlUp).Row
        If i = 1 Then
            R_end = R_end1
        Else
            R_end = Application.WorksheetFunction.Max(R_end1, R_end2)
        End If
        R_end2 = R_end
    Next

    '最終(列・行)
    R_Max = Rows.Count
    C_Max = Columns.Count



●最初と最後のセル(選択範囲)

R_top = Selection.Cells(1).Row '最初のセルの行
R_end = Selection.Cells(Selection.Count).Row '最後のセルの行
C_top = Selection.Cells(1).Column '最初のセルの列
C_end = Selection.Cells(Selection.Count).Column '最後のセルの列


    'LastCell
    R_end = Range("A1").SpecialCells(xlLastCell).Row
    Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select
    Range("A1").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select


        'http://www.moug.net/tech/exvba/0050104.html

        'xlPasteAllExceptBorders    罫線を除く全て
        'xlPasteColumnWidths        列幅

    '選択範囲を変数設定
    Set vCell = Application.ActiveCell


    '●Value2
    Range("A1") = "1/1"
    buf = Cells(1, 1).Value        '2014/01/01
    buf = Cells(1, 1).Value2       '41640



'○範囲の取得

    --- 範囲 ---

    Selection.Value = "□"

'使用している行数 (R_end - R_top - 1)
Set vRng = ActiveSheet.UsedRange
Cnt = vRng.Rows.Count

':上下
R_top = vRng.Row
R_end = vRng.Row + vRng.Rows.Count - 1
':左右
C_left = vRng.Column
C_right = vRng.Column + vRange.Columns.Count - 1

'最右列と最終行を求めた結果
MsgBox "最右列は : " & C_right
MsgBox "最終行は : " & R_end

'最左列と開始行を求めた結果
MsgBox "最左列は : " & C_left
MsgBox "開始行は : " & R_top


    '●可視セル
    Set vCell = Range("A1:D9").SpecialCells(xlCellTypeVisible)
    Range(Cells(1, 1),Cells(R_end, 1)).SpecialCells(xlCellTypeVisible).Copy
    R_top = Range("A2:A" & R_end).SpecialCells(xlVisible)(1).Row
    Range("A1").AutoFilter Field:=1, Criteria1:="□"
    Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Select


●可視セルは、Row_topが先頭行だと正常に処理できない仕様(全てのセルが対象になる)
Range("A1").AutoFilter Field:=1, Criteria1:=1
R_end = Cells(Rows.Count, 1).End(xlUp).Row
If R_end = 1 Then
Else
    If R_end = 2 Then
        Range("A2") = "=C2"
    Else
        R_top = Range("C2:C" & R_end_C).SpecialCells(xlVisible)(1).Row
        Range("A2:A" & R_end).SpecialCells(xlCellTypeVisible) = "=C" & R_top
    End If
End If
ActiveSheet.ShowAllData

Range("A1").AutoFilter Field:=1, Criteria1:=1
R_end = Cells(Rows.Count, 1).End(xlUp).Row
If R_end = 1 Then
Else
    C_add = Split(Cells(1, C_end2 + 1).Address, "$")(1)
    R_cnt = WorksheetFunction.CountA(Range(Cells(2, 1), Cells(R_end, 1)))
    If R_end = 2 Then
        R_top = 2
    Else
        R_top = Range(Cells(2, 1), Cells(R_end, 1)).SpecialCells(xlVisible)(1).Row
    End If
    If R_cnt = 1 Then
        Cells(R_end, 1) = "=" & C_add & R_top
    Else
        Range(Cells(2, 1), Cells(R_end, 1)).SpecialCells(xlCellTypeVisible) = "=" & C_add & R_top
    End If
End If
ActiveSheet.ShowAllData



'■検索
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

    '●検索列の設定
    C = Rows(1).Find(What:="□").Column
    C = Rows(1).Find(What:="□", LookAt:=xlWhole, LookIn:=xlFormulas).Column
    R = Columns(1).Find(What:="□").Row
    R = Columns(1).Find(What:="□", LookAt:=xlWhole, LookIn:=xlFormulas).Row
    'LookAt:=    xlWhole:完全一致 xlPart:部分一致
    'LookIn:=    xlComments:コメント xlFormulas:数式 xlValues:値

'日付で検索
vData = Format(Date, "m/d")
    R = Columns("A").Find(What:=vData, LookIn:=xlFormulas).Row

    Set vCell = Columns("A").Find(What:=vData, LookIn:=xlFormulas)
If FoundCell Is Nothing Then
Else
□ = □
End If

    '●検索の順序を指定。逆方向
    C = Rows(1).Find(What:="□", SearchDirection:=xlPrevious).Column

●位置(左から検索)
n = InStr(文字列, 検索値)
●位置(右から検索)
n = InStrRev("文字列", "文字")

'●日付で検索
vData = Format(Date, "m/d")
Set FoundCell = Columns("A").Find(What:=vData, LookAt:=xlPart, LookIn:=xlFormulas)
If Not FoundCell Is Nothing Then
End If

    '検索選択
    Rows(1).Select
    Rows(1).Find(What:="□", LookIn:=xlFormulas, LookAt:=xlWhole).Activate
    '次を検索
    Cells(1, 1).Select
    Cells.Find(What:="□", After:=ActiveCell).Activate



'■置換
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

    '●置換
     Rows("2:10").Replace What:="置換前", Replacement:="置換後", LookAt:=xlPart
     Cells.Replace What:=vData_置換前, Replacement:=vData_置換前, LookAt:=xlPart
     Cells.Replace vbLf, "", xlPart                                                 'セル内改行削除

'[デフォルト値]
'LookAt:=xlPart xlWhole '部分一致、完全一致
'SearchOrder:=xlByRows xlByColumns '検索の方向
'MatchCase:=False True '大文字小文字区別しない、True:する
'SearchFormat:=False True '書式の指定
'ReplaceFormat:=False True '書式
'MatchByte:=False True '全角と半角を区別しない

'●ひらがな→カタカナ
    置換後 = StrConv(置換文字, vbHiragana)

'vbUpperCase 大文字
'vbLowerCase 小文字
'vbWide 全角
'vbNarrow 半角
'vbKatakana カタカナ
'vbHiragana ひらがな

'●スペース削除
    先頭のスペース削除 = LTrim(□)
    末尾のスペース削除 = RTrim(□)
    先頭末尾のスペース削除 = Trim(□)

    '●『”(全角)』を削除()
    削除後文字列 = Replace(□, Chr(&H8168), "")

    '●(N/A)を削除する
    Cells.Replace What:="#N/A", Replacement:="", LookAt:=xlWhole


'改行を削除
Cells.Replace What:=vbLf, Replacement:=""


'英語(全角→半角)
vAry = "a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z," & _
   "A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z"
vText = Split(vAry, ",")
For i = 0 To UBound(vText)
Rows(R + 1).Replace What:=vText(i), Replacement:=Application.WorksheetFunction.Asc(vText(i))
Next


●大文字・小文字
EXCEL = UCase("Excel")
excel = LCase("Excel")



'■処理
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

'○貼り付け・クリア

    '●Clear
    Range("□").Clear
    Range("□").ClearContents   '書式は保存される
    Range("□").ClearFormats    '書式

    '●貼り付け
    Cells(1, 1).PasteSpecial Paste:=xlPasteAll
    Cells(1, 1).PasteSpecial Paste:=xlPasteValues
    Cells(1, 1).PasteSpecial Paste:=xlPasteFormulas     '数式
    Cells(1, 1).PasteSpecial Paste:=xlPasteFormats      '書式

    '縦横変換
    Range("□").Select
    Selection.PasteSpecial Transpose:=True
    Application.CutCopyMode = False

'●コピペ
    Range("□").Copy Sheets("□").Cells(1, 1)

Sheets(1).Columns(1).Copy Sheets(2).Columns(1)
Sheets("□").Cells(1, 1) = Sheets("B").Cells(1, 1) 'A=Bのとき、Bは1つのセルのみ指定できる

    '別シートを選択
    Application.Goto Sheets("2").Cells(2, 2)

    '別シートをコピー
    On Error Resume Next
    Application.Goto Sheets("2").Cells(2, 2).Copy
    Cells(1, 1).PasteSpecial Paste:=xlPasteAll
    On Error GoTo 0


'アクティブシートを切り替えない
Set ws1 = Sheets(ActiveSheet.Name)
'Set ws1 = Sheets("①")
Set ws2 = Sheets("②")

R_end1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
R_end2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To R_end1
    n = ws1.Cells(i, 1)
    R = ws2.Columns(1).Find(What:=n, LookAt:=xlWhole).Row
Next


'●開かずにデータ操作 ・・・ R1C1型で書く
Range("A1") = ExecuteExcel4Macro("'D:\Excelマクロ\一覧\a\[test.xlsx]Sheet1'!R1C1")
Range("A1") = ExecuteExcel4Macro("AVERAGE('D:\Excelマクロ\一覧\a\[test.xlsx]Sheet1'!R1C1:R10C1)")



'○数式 - http://excel-ubara.com/EXCEL/EXCEL903.html


    '●数式を延長
    Range("D2").AutoFill Destination:=Range("D2:D" & R_end)
Range("D2:D" & R_end).FillDown

    '●数式
    Cells(2, 2).FormulaR1C1 = "=ISNUMBER(RC[-1])"
    Range("P6") = "=VLOOKUP(N6,[" & vFile_old & "]集計用!N:O,2,0)"
    Range("P6") = "='[【マスタ】アンタッチャブルリスト130128 .xlsx]Sheet1'!$D$13759"
    Range("P6") = "=IF(COUNTIF($C10:C15029,C10)>1," * ","")"
    Range("D1") = "=IF(COUNTIF(C:C,C4)>1,""*"","""")"
    Range("D1") = "=IF(COUNTIF(" & vSheet & "!C:C,C4)>1,""*"","""")"

    Range("D1") = WorksheetFunction.VLookup(Range("C3"), Sheets("商品データ").Range("A:D"), 2, False)
    R_end = Application.WorksheetFunction.Max(R_end_A, R_end_E)

    'ファイル名を変数化して数式に代入
    vFile = ActiveWorkbook.Name
    Range("K4") = "=IF(COUNTIF('[" & vFile & "]Sheet1'!$C:$C,C4)>1,"" * "","""")"

    '●マクロで使用できない関数を使う
    Range("D1") = Evaluate("ADDRESS(1,5,4)")
    Range("D1") = Evaluate("left(ADDRESS(1," & vC & ",4),len(ADDRESS(1," & vC & ",4))-1)")


'●文字列としての計算式を計算
Dim strCalc As String
数式 = "(10+20)*2"
Range("A1") = ExecuteExcel4Macro("EVALUATE(" & 数式 & ")")



'○判断

'●判断(IS関数)
IsNumeric(□)
IsDate(□)
IsError(□)
IsEmpty(□)
IsArray(□)

'●数式が入力されているとき
If Cells(1, 1).HasFormula Then
End If


●セルに###が表示されているか判定
If Not IsError(vCell) Then
If vCell.Value <> vCell.Text And Left(vCell.Text,1) = "#" Then
'
End If
End If


'○条件処理

    '●無重複抽出

    R_end = Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(1, 1), Cells(R_end, 1)).RemoveDuplicates Columns:=1, Header:=xlNo


'C2に抽出結果を出す
Range("B2:B10").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("C2"), Unique:=True


'●別Bookに無重複抽出(1列)
Selection.Copy
Workbooks.Add
ActiveSheet.Paste

'重複削除
R_end = Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Range(Cells(1, 1), Cells(R_end, 1)).RemoveDuplicates Columns:=1, Header:=xlNo
'並べ替え
ActiveSheet.Sort.SortFields.Add Key:=Range("A1"), Order:=xlAscending
With ActiveSheet.Sort
    .SetRange Range(Cells(1, 1), Cells(R_end, 1))
    .Header = xlNo
    .Apply
End With


別Bookに無重複抽出(2列以上)
Dim vRng As Range
Dim i, C_cnt As Long
Dim vAry() As Variant

Set vRng = Range(Selection.Address)
C_cnt = vRng.Columns.Count

ReDim vAry(0 To C_cnt - 1)
For i = 1 To C_cnt
    vAry(i - 1) = i
Next

vRng.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
vRng.RemoveDuplicates Columns:=(vAry), Header:=xlNo



Range("B2:B9").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("C2"), Unique:=True


    '●Select Case
    A = InputBox("数値を入力してください")
    Select Case A
    Case Is < 10
        MsgBox "10より小さい"
    Case Is > 20
        MsgBox "20より大きい"
    Case Else
        MsgBox "条件に当てはまりません"
    End Select

    Select Case p.Value
        Case "A", "C"       '表示アイテム名をカンマ区切りで指定
        Case Else
            p.Visible = False
    End Select



'■配列
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

    Dim A(1 To 10) As String
    Dim vData As Variant

    vData = Array("東京都", "北海道", "愛知県")

    Range("A1") = vData(0)
    Range("A2") = vData(1)
    Range("A3") = vData(2)


    pref(0) = "東京都"
    pref(1) = "大阪府"
    pref(2) = "愛知県"

    src = "茨城県"

    For i = 0 To 2
        If src = pref(i) Then
            msg = "一致しました"
        End If
    Next i


    '●配列で変数をセット

    For i = 0 To 99
         Numbers(i) = i
    Next

 

b2_フィルタ_17-1101★

 投稿者:(^・(O_O)・^)  投稿日:2017年11月 1日(水)03時17分1秒
  b2_フィルタ_10**

Function b2_フィルタ()


'■フィルタ設定判断
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

    '●全て表示
    Sheets("□").Select
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0


'●オートフィルタの設定判断
Dim vRng As AutoFilter
Set vRng = ActiveSheet.AutoFilter
If Not vRng Is Nothing Then
    MsgBox "設定されています"
Else
    MsgBox "設定されていません"
End If

'③
Dim vRng As AutoFilter
Set vRng = ActiveSheet.AutoFilter
If TypeName(vRng) = "AutoFilter" Then
    '
Else
    '
End If

'Excel 2003までは、各列の状態を調べなければならない (FilterModeプロパティは、Excel 2007で追加)
Dim n As Long
If ActiveSheet.AutoFilterMode Then
    n = ActiveSheet.AutoFilter.Filters.Count
End If


'●フィルタのタイトル
Dim i As Long, Title As String
If ActiveSheet.AutoFilterMode Then
    For i = 1 To ActiveSheet.AutoFilter.Filters.Count
        If ActiveSheet.AutoFilter.Filters(i).On Then
            Title = ActiveSheet.AutoFilter.Range.Cells(1, i)
        End If
    Next i
End If

    '●絞り込み状況 :状態・列数・判定


    '状態
    If ActiveSheet.AutoFilterMode Then
        If ActiveSheet.AutoFilter.FilterMode Then
            MsgBox "絞り込まれています"
        Else
            MsgBox "絞り込まれていません"
        End If
    End If

    '列数
    If ActiveSheet.AutoFilterMode Then
        n = ActiveSheet.AutoFilter.Filters.Count
    End If

    '判定
    If ActiveSheet.AutoFilterMode Then
        For i = 1 To ActiveSheet.AutoFilter.Filters.Count
            If ActiveSheet.AutoFilter.Filters(i).On Then
                MsgBox i & "列目で絞り込まれています"
            End If
        Next i
    End If



'■フィルタ解除
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

    'フィルタ解除①
    If ActiveSheet.AutoFilterMode = True Then
     ActiveSheet.AutoFilterMode = False
    End If
    'フィルタ解除②
    Dim myRange As AutoFilter
    Set myRange = ActiveSheet.AutoFilter
    If Not myRange Is Nothing Then
     Range("A1").AutoFilter
    End If

    'ソート解除
    If ActiveSheet.FilterMode = True Then
     ActiveSheet.ShowAllData
    End If

    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    Range("A1:Z9").AutoFilter

    '設定したソートをクリア
    ActiveSheet.Range("F1").AutoFilter Field:=6



'■フィルタ設定
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

    Columns("A:E").AutoFilter
    Range("A1:Z9").AutoFilter

    '●並べ替え(フィルタ有り)
    ActiveSheet.AutoFilter.Sort.SortFields.Clear
    ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range("E4"), Order:=xlAscending
    With ActiveSheet.AutoFilter.Sort
        .Header = xlYes
        .Apply
    End With

    'Order:=xlAscending     昇順
    'Order:=xlDescending    降順

    '●並べ替え(フィルタ無し)
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("A3"), Order:=xlAscending
    With ActiveSheet.Sort
        .SetRange Range("A3:D" & vR_end)
        .Header = xlNo
        .Apply
    End With

    '●フィルタ

    Selection.AutoFilter
    Selection.AutoFilter Field:=1, Criteria1:="●字"

    'C列でフィルタ(フィルタ設定はB:E)
    Range("C1").AutoFilter Field:=2, Criteria1:="文字"
    Range("B1:E11").AutoFilter Field:=2, Criteria1:="文字"
    Range("K1").AutoFilter Field:=11, Criteria1:="<>5", Operator:=xlAnd

    '日付でフィルタ①
    'http://officetanaka.net/excel/vba/tips/tips151.htm
    Dim vData As Date
    Range("A1").AutoFilter Field:=1, Criteria1:=vData
    '日付でフィルタ②
    Range("A1").AutoFilter Field:=1, Criteria1:=DateValue("2010/8/22")
    '日付でフィルタ③
vData = Format(Date, "m/d")
Set FoundCell = Columns("A").Find(What:=vData, LookAt:=xlPart, LookIn:=xlFormulas)
If Not FoundCell Is Nothing Then
    Range("A1").AutoFilter Field:=1, Criteria1:=vData
End If

    '複数の条件
    Range("C1:G10").AutoFilter Field:=3, _
    Criteria1:="=●1", Operator:=xlOr, Criteria2:="=●2"

    '指定の条件だけ表示
    Range("C1:G10").AutoFilter Field:=3, _
    Criteria1:=Array("A", "B", "D"), Operator:=xlFilterValues


    'Criteria1:="=a"
    'Criteria1:="="         空白
    'Criteria1:="<>" 空白以外
    'Criteria1:="<>a"
    'Criteria1:="=*a*"
    'Criteria1:="<>*a*"
    'Criteria1:=">=3"

    'Operator:=xlOr
    'Operator:=xlAnd


    '●並べ替え
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("A1")
    With ActiveSheet.Sort
        .SetRange Selection
        .Header = xlNo
        .Apply
    End With

    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("A1")
    With ActiveSheet.Sort
        .SetRange Columns(1)
        .Header = xlYes
        .Apply
    End With


    '●無重複抽出(列単位)
C_end = Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 1 To C_end

        R_end = Cells(Rows.Count, i).End(xlUp).Row
        '無重複抽出
        ActiveSheet.Columns(i).RemoveDuplicates Columns:=1, Header:=xlYes
        '並べ替え
        ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Clear
        ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Add Key:=Cells(1, i)
        With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort
            .SetRange Range(Cells(1, i), Cells(R_end, i))
            .Header = xlYes
            .Apply
        End With

    Next i


    '●無重複抽出(ファイル)
    R_end = Cells(Rows.Count, i).End(xlUp).Row
    Range(Cells(2, C), Cells(R_end, C)).Copy

    If flg = 0 Then
        Worksheets.Add After:=Sheets(Sheets.Count) ' = "無重複抽出"
        ActiveSheet.Name = "無重複抽出"
        Cells(1, 1).PasteSpecial Paste:=xlPasteValues
        flg = 1
    ElseIf flg = 1 Then
        Sheets("無重複抽出").Select
        R_end = Cells(Rows.Count, 1).End(xlUp).Row
        Cells(vRow_end + 1, 1).PasteSpecial Paste:=xlPasteValues
    End If


    '並べ替え
    R_end = Cells(Rows.Count, i).End(xlUp).Row
    Range(Cells(1, 1), Cells(R_end, 1)).Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("A1")
    With ActiveWorkbook.Worksheets("無重複抽出").Sort
        .SetRange Selection
        .Header = xlNo
        .Apply
    End With

    '抽出
    R_end = Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(1, 1), Cells(R_end, 1)).RemoveDuplicates Columns:=1, Header:=xlNo

    '貼り付け
    R_end = Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(1, 1), Cells(R_end, 1)).Copy
    Sheets("□").Select
    Cells(4, 1).PasteSpecial Paste:=xlPasteAll

    '作業シートの削除
    Application.DisplayAlerts = False
    Sheets("無重複抽出").Delete
    Application.DisplayAlerts = True


    '●無重複抽出(1列ごとの設定)
    C_end = Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 1 To C_end

        R_end = Cells(Rows.Count, i).End(xlUp).Row

        ActiveSheet.Columns(i).RemoveDuplicates Columns:=1, Header:=xlYes
        ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Clear
        ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Add Key:=Cells(1, i)
        With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort
            .SetRange Range(Cells(1, i), Cells(R_end, i))
            .Header = xlYes
            .Apply
        End With

    Next i



End Function
 

c1_シート_17-1101★

 投稿者:(^・(O_O)・^)  投稿日:2017年11月 1日(水)03時16分24秒
  c1_シート_0425

Function c_シート()


    vSheet = Sheets(1).Name
    vSheet = Sheets(Sheets.Count)
    vSheet_cnt = Sheets.Count

    '●全てのシート
    Sheets.Select

    '●作成
    Worksheets.Add Before:=Sheets(1)
    Worksheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Copy After:=Sheets(ActiveSheet.Name)
    ActiveSheet.Copy Before:=Sheets(ActiveSheet.Name)
    Worksheets.Add.Name = "●"

    ActiveSheet.Name = "●"

    '●コピー
    Sheets(Array("①", "②", "③")).Copy

    Worksheets.Add.Name = "New1"
    '●シート表示
    Sheets("□").Visible = True


    '●シート非表示
    Sheets(Array("□1", "□2", "□3")).Visible = False
'●ウィンドウの表示
ActiveWindow.Visible = False
Windows(vFile).Visible = True

    '●シート削除

    'フォルダ指定
    Application.DisplayAlerts = False
    Sheets(Array("□1", "□2", "□3")).Select
    ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True

'●シートがあるか判断
For Each ws In Worksheets
     If ws.Name = "□" Then
     End If
Next

    '指定のシート以外削除
    Application.DisplayAlerts = False
    For Each vSheet In Worksheets
    If (vSheet.Name <> "Menu") And (vSheet.Name <> "未処理") Then
        vSheet.Delete
    End If
    Next
    Application.DisplayAlerts = True

    '●[Ctrl]+[Tab]
    ActiveWindow.ActivateNext

    '●ワークシート判断
    If (TypeName(ActiveSheet) <> "Worksheet") Then
    End If

     '●ワークシート判断
    For Each ws In Sheets
        If ws.Name Like "*" & vSheet & "*" Then
            Sheets(ws.Name).Select
        End If
    Next

    '●指定のシート以外削除
    Application.DisplayAlerts = False
    For Each vSheet In Worksheets
        If vSheet.Name <> "Main" Then
            vSheet.Delete
        End If
    Next
    Application.DisplayAlerts = True

    '●ファイル新規()

    Workbooks.Add
    vFile = ActiveWorkbook.Name

    '●シートを移動
    Windows("元ファイル.xlsx").Activate
    Sheets("Sheet1").Move After:=Workbooks("Book1").Sheets(Sheets.Count)



'●シートの存在確認

ws_name = InputBox(Prompt:="シート名の入力")

'シート名が数字のとき
If IsNumeric(ws_name) Then
    ws_name = "" & ws_name & ""
End If


'シートの存在確認
If ws_name = "" Then
    Exit Sub
End If

flg = 0
For Each ws In Worksheets
    If ws.Name = ws_name Then
        flg = 1
        Exit For
    End If
Next
If flg = 0 Then
    MsgBox ws_name & " シートは存在しません"
    Exit Sub
Else
    MsgBox ws_name & " シートは存在します"


End Sub
 

c2_ファイル_フォルダ_17-1101★

 投稿者:(^・(O_O)・^)  投稿日:2017年11月 1日(水)03時15分52秒
  c2_ファイル_フォルダ0421

Function c_ファイルパス()


'○ファイル
    vFile0 = ThisWorkbook.Name
    vFile1 = ActiveWorkbook.Name
    Windows(ThisWorkbook.Name).Activate
    Windows(vFile_元).Activate

'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -


ActiveSheet.Copy

Set vBook0 = Windows(ThisWorkbook.Name)
Set ws0 = Sheets(ActiveSheet.Name)
Set vBook1 = Windows(ActiveWorkbook.Name)
Set ws1 = Sheets(ActiveSheet.Name)

'ThisWorkbook.Activate
vBook0.Activate
vBook1.Activate

' ■ファイル操作
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

'●拡張子を除くファイル名
Set FSO = CreateObject("Scripting.FileSystemObject")
vFile0 = FSO.GetBaseName("C:\Work\Book1.xls")

    '●指定パスを開く
    If Dir(vPath) <> "" Then
        Workbooks.Open vPath
    Else
        MsgBox vPath & vbCrLf & "が存在しません"
    End If

    '●個別で開く
    Workbooks.Open Filename:=vFolder & "\" & vFile & ".xlsx"
    vFile = ActiveWorkbook.Name

    '●ファイルの存在確認
    vFile = Dir(vFolder & "\" & "*", vbNormal)
    If vFile = "" Then
        Application.ScreenUpdating = True
        MsgBox "指定のフォルダに、ファイルは存在しません。", vbExclamation
        Exit Function
    End If

    'フォルダの存在確認2
    On Error Resume Next
    Set objFS = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFS.GetFolder(vFolder & "\")
    If objFolder = Empty Then
        MsgBox "指定のフォルダはありません"
        End
    End If

    '●フォルダの指定(ダイアログボックス)
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            vFolder = .SelectedItems(1)
        End If
    End With

    '●フォルダ名の設定
    'パターン1
    Do While (Dir(vFolder & "\" & vFolder_作業済, vbDirectory) <> "")
        枝番 = 枝番 + 1
        vFolder_作業済 = vFolder_作業済0 & "(" & 枝番 & ")"
    Loop

    'パターン2
    vData = Format(Date, "yymmdd")
    枝番 = 1
    vFile = vFolder & "\●" & vData & ".xlsx"
    Do While (Dir(vFile, vbDirectory) <> "")
        vFile_保存 = vFolder & "\●" & vData & "-" & 枝番 & ".xlsx"
        枝番 = 枝番 + 1
    Loop

    '●データの移動
    Dim vFolder_移動 As Object
    Set vFolder_移動 = CreateObject("Scripting.FileSystemObject")
    vFile_前 = vFolder & "\" & vFile_更新済
    vFile_後 = vFolder & "\" & vFolder_作業済 & "\"
    vFolder_移動.MoveFile vFile_前, vFile_後
    Set vFolder_移動 = Nothing

    '●閉じる
    ActiveWorkbook.Save
    Windows(vFile_name元).Close savechanges:=False
    Windows(vFile_name先).Close savechanges:=True

    '●ファイル数
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Cnt = FSO.GetFolder("●パス").Files.Count
    Set FSO = Nothing

    If vCount = 0 Then
    Else
        vCount = vCount - 1
    End If

    Cells(i, 3) = vCount


' ■ダイアログボックスを表示
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

    '●ダイアログボックスを表示
    vDrive = Left(Sheets("□").Range("□").Value, 1)
    vFolder = Sheets("□").Range("□")

    ChDrive vDrive
    ChDir vFolder
    vFile = Application.GetOpenFilename("Microsoft Excelブック,*.CSV")
    If vFile = False Then Exit Sub

    '●ダイアログボックスを表示2
    ChDrive "D"
    ChDir "□フォルダパス"
    フィルタ = "Excel File,*.xls"
    タイトル = "ファイルの指定(複数ファイルの指定可)"
    ファイル郡 = Application.GetOpenFilename(FileFilter:=フィルタ, Title:=タイトル, MultiSelect:=True)



' ■パスの出力
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

    '●フォルダパス一覧
    i = 2
    For Each objSubFolder In objFolder.subFolders
        Cells(i, 1) = objSubFolder
        i = i + 1
    Next

    '●フォルダ名一覧
    i = 2
    Do While (Cells(i, 1) <> "")
        vFolder = Cells(i, 1)
        vFolder = Dir(vFolder, vbDirectory)
        Cells(i, 2) = vFolder
        i = i + 1
    Loop


    '●先頭のファイル名の取得
    vFile = Dir(vFolder & cnsDIR, vbNormal)

    '●ファイル一覧
    i = 2
    Do While (Cells(i, 1) <> "")

        vFolder = Cells(i, 1)
        vFile = Dir(vFolder & "\" & "*", vbNormal)

        Do While vFile <> ""
            Cells(i, 2) = vFile
            vFile = Dir()
        Loop

        i = i + 1

    Loop

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

    '●サブフォルダ一覧

    Dim objFS, objFolder, objSubFolder As Object
    Dim vFolder As Variant
    Dim i As Long

    vFolder = Range("B1")
    i = 1

    'フォルダの存在確認
    On Error Resume Next
    Set objFS = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFS.GetFolder(vFolder & "\")
    If objFolder = Empty Then
        MsgBox "指定のフォルダはありません"
        End
    End If

    'サブフォルダ一覧
    i = 2
    For Each objSubFolder In objFolder.subFolders
        Cells(i, 2) = objSubFolder
        i = i + 1
    Next

    'サブフォルダ一覧2
    i = 1
    buf = Dir(vFolder & "\" & "*", vbDirectory)
    Do While buf <> ""
        If InStr(buf, ".") = 0 Then
    Cells(i, 1) = buf
    End If
         buf = Dir()
    Loop


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

Sub サブフォルダ情報()

Application.ScreenUpdating = False

MaxRow = Rows.Count
vFolder = Sheets("■").Range("■")

'●シートのクリア
Rows("2:" & MaxRow).ClearContents


'●フォルダの存在確認
On Error Resume Next
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(vFolder & "\")
If objFolder = Empty Then
    Sheets("マスタ").Select
    Application.ScreenUpdating = True
    Range("■").Select
    MsgBox "指定のフォルダに、ファイルは存在しません。", vbExclamation
    End
End If


'●フォルダパス一覧
i = 2
For Each objSubFolder In objFolder.subFolders
    Cells(i, 1) = objSubFolder
    i = i + 1
Next


'●フォルダ名一覧
i = 2
Do While (Cells(i, 1) <> "")
    vFolder = Cells(i, 1)
    vFolder = Dir(vFolder, vbDirectory)
    Cells(i, 2) = vFolder
    i = i + 1
Loop


'●ファイル一覧
i = 2
Do While (Cells(i, 1) <> "")

    vFolder = Cells(i, 1)
    vFile = Dir(vFolder & "\" & "*", vbNormal)
    flag = False
    Do While vFile <> ""
        If flag = False Then
            Cells(i, 3) = vFile
            flag = True
        Else
            i = i + 1
            Rows(i).Insert
            Cells(i, 1) = Cells(i - 1, 1)
            Cells(i, 2) = Cells(i - 1, 2)
            Cells(i, 3) = vFile
        End If
        vFile = Dir()
    Loop

    i = i + 1
Loop


Application.ScreenUpdating = True

End Sub


-------------------------------------------------------------------------------------------------------
    '●別のフォルダにコピー
    '
    FileCopy Source:="C:\移動前\ファイル.拡張子", _
        Destination:="C:\移動跡\ファイル.拡張子"
    '
    i = 2
    Do While Cells(i, 3) <> ""
        If Cells(i, 3) = 1 Then
            vFile_元 = □パス
            vFile_先 = □パス
            FileCopy Source:=vFile_元, _
                 Destination:=vFile_先
        End If
        i = i + 1
    Loop



'○一括処理

    vFolder = Sheets("□").Range("□").Value
    vFile = Dir(vFolder & "\" & "*", vbNormal)

    '●一括処理(移動なし)
    Do While v_File <> ""

        If v_File = ActiveWorkbook.Name Then
            v_File = Dir()
        Else
            Workbooks.Open Filename:=v_Folder & "\" & v_File, UpdateLinks:=0
            vFile_元 = ActiveWorkbook.Name

            'ファイル設定
            Application.DisplayAlerts = False
            Windows(vFile).Close savechanges:=True
            Application.DisplayAlerts = True
            v_File = Dir()

        End If
    Loop

    '●一括処理(移動あり)
    Do While v_File <> ""

        If v_File = ActiveWorkbook.Name Then
            v_File = Dir()
        Else
            Workbooks.Open Filename:=v_Folder & "\" & v_File, UpdateLinks:=0
            vFile_元 = ActiveWorkbook.Name

            'ファイル設定
            Application.DisplayAlerts = False
            Windows(vFile).Close savechanges:=True
            Application.DisplayAlerts = True
            vFile_更新済 = vFile
            v_File = Dir()

            'データの移動
            Dim vFolder_移動 As Object
            Set vFolder_移動 = CreateObject("Scripting.FileSystemObject")
            vFile_前 = vFolder & "\" & vFile_更新済
            vFile_後 = vFolder & "\" & vFolder_作業済 & "\"
            vFolder_移動.MoveFile vFile_前, vFile_後
            Set vFolder_移動 = Nothing


        End If
    Loop

'■フォルダ設定
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■

'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

'  ●ネットワークパス:http://officetanaka.net/other/extra/tips15.htm
'
'   Public と同じ箇所に記載
'    Declare Function SetCurrentDirectory Lib "kernel32" Alias _
'    "SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long
'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    SetCurrentDirectory "\\172.16.0.232\CoffeeCrazy2\"
    ChDir "fol1\fol2\fol3"

    vFolder1 = Sheets("Menu").Range("フォルダ名1").Value
        SetCurrentDirectory vFolder1

       MsgBox "『接触済みリスト』を選択してください", Title:="ファイルの指定"
        vFile_Name1 = Application.GetOpenFilename("Microsoft Excelブック,*.csv")
        If vFile_Name1 = False Then End



    '●フォルダ名を変更
    Name "C:\Work\1000" As "C:Work\2000"
    '●フォルダを移動
    Name "C:\Work\1000" As "C:Work\Sub\2000"

    '●フォルダ削除
    vFolder = "C:Work\2000"
    If Dir(vFolder, vbDirectory) <> "" Then
        RmDir vFolder
    End If


    '●フォルダ作成して、作業済みファイルを移動

    '☆1
    '変数設定
    vFolder = Sheets("□").Range("□").Value
    vData = Format(Date, "mmdd")
    vTime = Format(Now, "hhmm")
    vFolder_作業済 = "作業済" & "_" & vData & "-" & vTime
    vFolder_作業済0 = vFolder_作業済
    枝番 = 1
    'フォルダ名の設定
    Do While (Dir(vFolder & "\" & vFolder_作業済, vbDirectory) <> "")
        枝番 = 枝番 + 1
        vFolder_作業済 = vFolder_作業済0 & "(" & 枝番 & ")"
    Loop
    'フォルダ作成
    MkDir vFolder & "\" & vFolder_作業済

    '☆2
    If Dir(vFolder & "\作業済", vbDirectory) = "" Then
        MkDir vFolder & "\作業済"
        vFolder_作業済 = "作業済"
    Else
        vData = Format(Date, "mmdd")
        vTime = Format(Now, "hhmm")
        MkDir vFolder & "\作業済" & "_" & vData & "-" & vTime
        vFolder_作業済 = "作業済" & "_" & vData & "-" & vTime
    End If

End Function
 

レンタル掲示板
/6