おつかれさまです。

EXCEL パーツ(自分用です)

2018年12月20日

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

 マクロ 

改行コード

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 & " 実行OK? ", 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 & "処理実行OK?", 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%" />

がんばりましょう。