EXCEL パーツ（自分用です）

2018年12月20日2019年3月28日

じぶんの備忘用ページです。
コピペして作ることが多いので、すぐ忘れちゃうんですよね。

　マクロ　

改行コード

vbCr／Chr(13)    キャリッジリターン
vbLf／Chr(10)    ラインフィード
vbCrLf／Chr(13) + Chr(10)　上記の組み合わせ

8桁のテキストを日付形式にフォーマット

WORK01 = Format(set_data01.Offset(0, 0).Value, "@@@@/@@/@@")

他のEXCELを指定したシートに貼り付ける

mySheetName001 = "ExcelPaste" '### 貼り付けるシート名

MSG_FLG = MsgBox(mySheetName001 & ".xlsx →　取込" & vbCrLf & " 実行ＯＫ? ", vbYesNo)
If MSG_FLG = vbNo Then
   Exit Sub
End If

'### クリア処理
'### 全シートフィルタ解除サブプロシジャー ###
sheet_clear
'@@@シートにフィルタがかかっていると取込が失敗することがある為Moduleにさくせい。

'### シートクリア ###
Sheets(mySheetName001).Select
Worksheets(mySheetName001).Cells.Clear
Range("A1").Select

'###　取り込みEXCEL指定　　###
Const cnsTITLE = " 取込み（*.Xlsx）処理"
Const cnsFILTER = " (*.Xlsx),*.Xlsx"

'###　KANRIシートB1に取り込むファイルのフォルダ場所を書いておく　　###
With CreateObject("WScript.Shell")
    .CurrentDirectory = Worksheets("KANRI").Range("B1") 
End With

vFILENAME = Application.GetOpenFilename(FileFilter:=cnsFILTER, title:=cnsTITLE)
If VarType(vFILENAME) = vbBoolean Then
   MsgBox ("キャンセル")
   Exit Sub
End If

'### 元Sheet場所 セット
Set writeSheet = ThisWorkbook.Worksheets(mySheetName001) 
    
'### 相手EXCELオープン　選択して　copy
Set strBookName = Workbooks.Open(vFILENAME) 
Cells.Select
Selection.Copy
    
'### 自分EXCELシート、選択して貼り付け
writeSheet.Activate
Cells.Select
ActiveSheet.Paste

'### 相手EXCELクローズ
Application.DisplayAlerts = False
strBookName.Close savechanges:=False
Application.DisplayAlerts = True
 
'###　元選択してクリア
writeSheet.Activate
Set writeSheet = Nothing
Set strBookName = Nothing

MsgBox (".xls 取込み終了 ")
Range("A1").Select

sheet_clear

Sub sheet_clear()
'### 全シートフィルタ解除 サブプロシージャ ###
For CLEAR001 = 1 To Worksheets.Count
   If Sheets(Worksheets(CLEAR001).Name).AutoFilterMode Then
      Sheets(Worksheets(CLEAR001).Name).Range("A1").AutoFilter
   End If
Next
End Sub

【検索(FIND)】、検索先のデータが一つのとき

例）DAILYシートを検索して　データを取得。

       kensaku1 = set_data01.Offset(0, 0).value
       Set MyRange1 = Worksheets("DAILY").Columns(1).Find(kensaku1, LookAt:=xlWhole)
       If Not MyRange1 Is Nothing Then
          set_data01.Offset(0, 1).value = MyRange1.Offset(0, 1).value
       End If

【検索(FIND(】、検索先に複数データがあった時

例）DAILYシートを検索して　マッチしたデータを全て加算する

       kensaku1 = set_data01.Offset(0, 0).value
       Set MyRange1 = Worksheets("DAILY").Columns(1).Find(kensaku1, LookAt:=xlWhole)
       If Not MyRange1 Is Nothing Then
          firstAddress = MyRange1.Address
          
          Do
             set_data01.Offset(0, 1).value = set_data01.Offset(0, 1).value + MyRange1.Offset(0, 1).value
             
          Set MyRange1 = Worksheets("MASTER").Columns(1).FindNext(MyRange1)
          Loop While Not MyRange1 Is Nothing And MyRange1.Address <> firstAddress
       End If

マクロでEXCELのごみを消す。※初めて組み込むときはバックアップしてからね

'### データ / 接続　###
Do While ActiveWorkbook.Connections.Count > 0
   ActiveWorkbook.Connections.Item(ActiveWorkbook.Connections.Count).Delete
Loop

'### 数式 / 名前の管理　###
Do While ActiveWorkbook.Names.Count > 0
   ActiveWorkbook.Names.Item(ActiveWorkbook.Names.Count).Delete
Loop

クリーニング

Application.StatusBar = False
Unload me

CSV 出力

    mySheetName003 = "出力シート"

'  ***処理確認***
    MSG_FLG = MsgBox(mySheetName003 & " CSV作成 " & vbCrLf & "処理実行ＯＫ？", vbYesNo)
    If MSG_FLG = vbNo Then
       Exit Sub
    End If
    
   '### クリア処理（シートフィルタ解除サブプロシジー）###
    sheet_clear

   '### ファイル名セット ###
    WORK01 = Application.GetSaveAsFilename(Worksheets("KANRI").Range("B1") & "\【CSV】更新csv" & CStr(Format(Date, "yyyymmdd")) & "_" & CStr(Format(Time, "hhnnss")) & ".csv", "カンマ区切り形式 (*.csv), *.csv")
    IntFlNo = FreeFile '### ファイルNO取得
    Open WORK01 For Output As #IntFlNo '### ファイルOPEN

'===================================================================================

   '### ヘダー
    recfile = "商品コード,コメント"
    Print #IntFlNo, recfile '### 出力
   
   '### 指定明細抽出
    CNT01 = 0
    CNT02 = 0
    Set set_data01 = Worksheets(mySheetName003).Range("A1")
    Do Until set_data01.Offset(0, 0).value = ""
       If set_data01.Offset(0, 2).value = "Yes" Then
          recfile = "I:" & set_data01.Offset(0, 0).value & "," & set_data01.Offset(0, 1).value
          Print #IntFlNo, recfile '### 出力
          CNT02 = CNT02 + 1
       End If
       Application.StatusBar = "処理件数 >" & CNT02 & " / " & CNT01 & " 件"
       Set set_data01 = set_data01.Offset(1, 0)
       CNT01 = CNT01 + 1
    
    Loop
    
'===================================================================================
    
    Close #IntFlNo '### クローズ

    MsgBox (mySheetName003 & " 作成終了 " & CNT02 & " 件出力")
    
'###
'###

シートの図形削除

excelを丸っとコピーすると図形が一緒にコピーされてきて、気づいたらいっぱい重なってしまったこと無いですか。
この処理をコピーする前に入れておくと、画像を削除しします。

 '### シート図削除 ###
    Dim WKSHP01 As Shape
    For Each WKSHP01 In ActiveSheet.Shapes
       WKSHP01.Delete
    Next WKSHP01

　関数　

=TEXT(G12,"0000!/00!/00")

　HTML　

横線（ブログ用）
<hr width="100%" />