GetChild

Option Explicit

Sub GetFileList()

Dim MyPath '自分のパス
Dim TargetPath '検索パス
Dim FolderDepth '検索深度

MyPath = ThisWorkbook.Path

'検索パスのチェック
TargetPath = Sheet1.Cells(1, 2)
If Dir(TargetPath, vbDirectory) = "" Then
'処理終了
Debug.Print "処理終了!検索パスのチェック"
Exit Sub
End If

'検索深度のチェック
FolderDepth = Sheet1.Cells(2, 2)
If FolderDepth > 3 Or FolderDepth < 1 Then
'処理終了
Debug.Print "処理終了!検索深度のチェック"
Exit Sub
End If

'--------------------
'ps1ファイル作成
'--------------------

'--------------------
'batファイル作成
'--------------------

'--------------------
'batファイルの実行
'https://vbabeginner.net/vba%E3%81%A7%E3%83%90%E3%83%83%E3%83%81%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%EF%BC%88bat%EF%BC%89%E3%82%92%E5%AE%9F%E8%A1%8C%E3%81%99%E3%82%8B/
'--------------------
Dim dProcessId As Double
Dim sPath

sPath = MyPath & "\run.bat"
dProcessId = Shell(sPath)


Debug.Print "処理終了!"
End Sub

'====================
'csvファイルの取込
'https://qiita.com/YTANRK_BIZ/items/9ea2beff4837f5f7b93e
'https://www.tipsfound.com/vba/18014
'https://tonari-it.com/excel-vba-querytable-csv-property/
'====================
Sub GetCsvFile()

Dim MyPath '自分のパス
MyPath = ThisWorkbook.Path

Dim SetFileName
SetFileName = MyPath & "\FileList.csv"

'表クリア
Sheet2.Range("A2", Range("A2").SpecialCells(xlLastCell)).Clear

'CSVファイル取込
With Sheet2.QueryTables.Add(Connection:="text;" & SetFileName, Destination:=Sheets(TargetSheet).Range("A2"))
.TextFilePlatform = 65001 'UTF-8
.AdjustColumnWidth = False '列の幅を自動計算しない
.TextFileStartRow = 3 ' X行目から読み込み
.TextFileCommaDelimiter = True 'コンマ区切り
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 1) '文字列にする
.Refresh BackgroundQuery:=False 'シートに出力
.Delete ' CSV との接続を解除
End With

Debug.Print "処理終了!"
End Sub

'====================
'列を整える
'====================
Sub ColumnFormat()

Dim lastrowno '最終行
lastrowno = Cells(1, 1).End(xlDown).Row

Dim TargetPath '検索パス
TargetPath = Sheet1.Cells(1, 2)

'----------
'modeを整える(フォルダ/ファイル)
'----------
Sheet2.Range("F2", "F" & lastrowno).Formula = "=IF(LEFT(A2,1)=""d"",""フォルダ"",""ファイル"")"
Sheet2.Range("F2", "F" & lastrowno).Copy
Sheet2.Range("F2").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheet2.Range("F2").Select

'----------
'親パスを整える
'----------
Sheet2.Range("E2", "E" & lastrowno).Formula = "=SUBSTITUTE(D2,""Microsoft.PowerShell.Core\FileSystem::"","""")"
Sheet2.Range("E2", "E" & lastrowno).Copy
Sheet2.Range("E2").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheet2.Range("E2").Select

'----------
'階層を整える
'----------
Sheet2.Range("G2", "G" & lastrowno).Formula = "=LEN(SUBSTITUTE(E2,""" & TargetPath & """,""""))-LEN(SUBSTITUTE(SUBSTITUTE(E2,""" & TargetPath & """,""""),""\"",""""))+1"
Sheet2.Range("G2", "G" & lastrowno).Copy
Sheet2.Range("G2").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheet2.Range("G2").Select

End Sub

 

keybd_event

Public Declare Sub keybd_event Lib "user32" ( _
ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long)

'bVk: Keycode
'bScan: Scancode、常に0
'dwFlags: 0:キーを押す / 1:0xE0を追加 / 2:キーを放す
'dwExtraInfo:常に0

Const EXTENDED_KEY = &H1 '押す > dwFlagsに入れる
Const KEYUP = &H2 '放す > dwFlagsに入れる

Public Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long


Function open_office_clipboard()

keybd_event vbKeyMenu, 0, 0, 0
keybd_event vbKeyW, 0, 0, 0
keybd_event vbKeyMenu, 0, KEYUP, 0
keybd_event vbKeyW, 0, KEYUP, 0

keybd_event vbKeyDown, 0, 0, 0
keybd_event vbKeyDown, 0, KEYUP, 0
keybd_event vbKeyDown, 0, 0, 0
keybd_event vbKeyDown, 0, KEYUP, 0
' keybd_event vbKeyDown, 0, 0, 0
' keybd_event vbKeyDown, 0, KEYUP, 0

End Function

Sub test2()

keybd_event vbKeyMenu, 0, 0, 0
keybd_event vbKeyW, 0, 0, 0
keybd_event vbKeyMenu, 0, KEYUP, 0
keybd_event vbKeyW, 0, KEYUP, 0

keybd_event MapVirtualKey(80, 1), 0, 0, 0
keybd_event MapVirtualKey(80, 1), 0, KEYUP, 0
keybd_event MapVirtualKey(80, 1), 0, 0, 0
keybd_event MapVirtualKey(80, 1), 0, KEYUP, 0
keybd_event MapVirtualKey(80, 1), 0, 0, 0
keybd_event MapVirtualKey(80, 1), 0, KEYUP, 0

End Sub

 

Sub test1()
'スキャンコードへ
Debug.Print MapVirtualKey(vbKeyDown, 0)
End Sub

 

Public Function SendKeys(InpKeys As String)
'CreateObject("WScript.Shell").SendKeys InpKeys

Dim o As Object
Set o = CreateObject("WScript.Shell") ' インスタンス
o.SendKeys InpKeys

' オブジェクトを使った処理
Set o = Nothing ' 最後に必ず Nothing を設定する

End Function

 

 

 

 

 

 

Option Explicit
Type coordinate
x As Long
y As Long
End Type

Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Declare Function GetCursorPos Lib "user32" (lpPoint As coordinate) As Long

Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long

Declare Sub mouse_event Lib "user32" ( _
ByVal dwFlags As Long, _
Optional ByVal dx As Long = 0, _
Optional ByVal dy As Long = 0, _
Optional ByVal dwDate As Long = 0, _
Optional ByVal dwExtraInfo As Long = 0)

Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)

Sub saveCoordinates()

Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("座標")

Const CLICKNUM As Long = 3

Dim currentClickNum As Long
currentClickNum = 0
Do While currentClickNum < CLICKNUM
If GetAsyncKeyState(1) < 0 Then
currentClickNum = currentClickNum + 1
Dim c As coordinate
GetCursorPos c
sht.Cells(1 + currentClickNum, 2) = c.x
sht.Cells(1 + currentClickNum, 3) = c.y
Sleep 300
End If
Loop

Set sht = Nothing

End Sub

Sub loadCoordinates()

Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("座標")

Const CLICKNUM As Long = 3

Dim currentClickNum As Long
Dim i As Long

'データを配列に格納
ReDim Haidata(10, 3)
Dim j
For j = 1 To 5
Haidata(j, 1) = "A" & j
Haidata(j, 2) = "1." & j
Haidata(j, 3) = "0.0" & j
Next j


For i = 2 To 3
Dim x As Long
Dim y As Long
x = sht.Cells(i + 1, 2)
y = sht.Cells(i + 1, 3)

SetCursorPos x, y

Sleep 1000

mouse_event 2 '左ボタン押下のコード
mouse_event 4 '左ボタン解放のコード

Sleep 1000

mouse_event 2 '左ボタン押下のコード
mouse_event 4 '左ボタン解放のコード

SendKeys "{Down}"

SendKeys Haidata(i, 1) & i

SendKeys "{Up}"

SendKeys Haidata(i, 2) & i

SendKeys "{Tab}"

SendKeys Haidata(i, 3) & i

SendKeys "{Tab}"

Sleep 1000

Next i

Set sht = Nothing

End Sub


Sub マウスで画面の任意の位置をクリック()
SetCursorPos 100, 35 '左から100ピクセル、上から35ピクセルの位置にカーソルを移動
mouse_event 2 '左ボタン押下のコード
mouse_event 4 '左ボタン解放のコード
End Sub

 

 

 

セルコピー3

実行対象 転記設定 転記先=保存先? 実行ログ                          
"実行する"
行のみ実行
転記元 転記先 保存先 貼付形式
(リストから選択)
(参考)保存先ハイパーリンク   (参考)
転記元Fパス
作成
  (参考)
転記先Fパス
作成
  (参考)
保存先Fパス
作成
フォルダパス ファイル名 シート名 セル範囲 フォルダパス ファイル名 シート名 セル範囲 フォルダパス ファイル名   フォルダ フォルダ(一般/マシナリ) フォルダ(Gr)   フォルダ フォルダ(一般/マシナリ) フォルダ(Gr)   フォルダ フォルダ(一般/マシナリ) フォルダ(Gr)
実行する C:\Users\Desktop\転記テスト\ 転記元.xlsx 転記元データbkup C4:C11 C:\Users\Desktop\転記テスト\店\SGr\ ○第一.xlsx BSC D3:D10 C:\Users\Desktop\転記テスト\店\SGr\ ○第一.xlsx 値と数値の書式 同じ(上書保存) OK)上書保存しました。 C:\Users\Desktop\転記テスト\店\SGr\○第一.xlsx   C:\Users\Desktop\転記テスト\       C:\Users\Desktop\転記テスト\ 店\ SGr\   C:\Users\Desktop\転記テスト\ 店\ SGr\
実行する C:\Users\Desktop\転記テスト\ 転記元.xlsx 転記元データbkup D4:D11 C:\Users\Desktop\転記テスト\店\SGr\ ○第二.xlsx BSC D3:D10 C:\Users\Desktop\転記テスト\店\SGr\ ○第二.xlsx 値と数値の書式 同じ(上書保存) OK)上書保存しました。 C:\Users\Desktop\転記テスト\店\SGr\○第二.xlsx   C:\Users\Desktop\転記テスト\       C:\Users\Desktop\転記テスト\ 店\ SGr\   C:\Users\Desktop\転記テスト\ 店\ SGr\
実行する C:\Users\Desktop\転記テスト\ 転記元.xlsx 転記元データbkup E4:E11 C:\Users\Desktop\転記テスト\店\SGr\ 第三.xlsx BSC D3:D10 C:\Users\Desktop\転記テスト\店\SGr\ ○第三.xlsx 値と数値の書式 異なる(別名保存) ERR)実行エラーによりスキップしました。(保存先ファイル) C:\Users\Desktop\転記テスト\店\SGr\○第三.xlsx   C:\Users\Desktop\転記テスト\       C:\Users\Desktop\転記テスト\ 店\ SGr\   C:\Users\Desktop\転記テスト\ 店\ SGr\
実行する C:\Users\Desktop\転記テスト\ 転記元.xlsx 転記元データbkup F4:F11 C:\Users\Desktop\転記テスト\店\1Gr\ ○第四.xlsx BSC E10:E17 C:\Users\Desktop\転記テスト\店\1Gr\ ◎第四.xlsx 値と数値の書式 異なる(別名保存) ERR)実行エラーによりスキップしました。(保存先ファイル) C:\Users\Desktop\転記テスト\店\1Gr\◎第四.xlsx   C:\Users\Desktop\転記テスト\       C:\Users\Desktop\転記テスト\ 店\ 1Gr\   C:\Users\Desktop\転記テスト\ 店\ 1Gr\
実行する C:\Users\Desktop\転記テスト\ 転記元.xlsx 転記元データ G4:G11 C:\Users\Desktop\転記テスト\店\1Gr\ ○第五.xlsx BSC E10:E17 C:\Users\Desktop\転記テスト\店\1Gr\ ○第五.xlsx 値と数値の書式 同じ(上書保存) OK)上書保存しました。 C:\Users\Desktop\転記テスト\店\1Gr\○第五.xlsx   C:\Users\Desktop\転記テスト\       C:\Users\Desktop\転記テスト\ 店\ 1Gr\   C:\Users\Desktop\転記テスト\ 店\ 1Gr\
実行する C:\Users\Desktop\転記テスト\ 転記元.xlsx 転記元データ H4:H11 C:\Users\Desktop\転記テスト\店\1Gr\ ○第六.xlsx BSC E10:E17 C:\Users\Desktop\転記テスト\店\1Gr\ ○第六.xlsx 値と数値の書式 同じ(上書保存) OK)上書保存しました。 C:\Users\Desktop\転記テスト\店\1Gr\○第六.xlsx   C:\Users\Desktop\転記テスト\       C:\Users\Desktop\転記テスト\ 店\ 1Gr\   C:\Users\Desktop\転記テスト\ 店\ 1Gr\

セルのコピー2

【概要】転記元のセルを、転記先に転記して、保存先に保存します。

※このシートの21行目を開始行とし、「実行対象」と「転記設定」が全て空欄の行を最終行とします。(最大100行目まで。)
※転記先ファイルと保存先ファイルが同じ場合は、転記先の上書保存になります。異なる場合は別名保存になります。


<エラー処理について>
※「実行対象」が"実行する"以外の行は実行対象外としてスキップします。
※「転記設定」に空欄セルが1つ以上ある場合は設定エラーとしてスキップします。
※転記元が存在しない又は誰かが開いている場合は実行エラーとしてスキップします。
※転記先が存在しない又は誰かが開いている場合は実行エラーとしてスキップします。
※保存先ファイルが既に存在している場合は実行エラーとしてスキップします。(ただし、転記先と保存先が同じ場合は上書き保存なので実行します。)

セルコピー

Option Explicit

'========================================
'自動セル転記
'========================================
Sub CopyCellAuto()

Dim setsheet
Dim cntrow
Dim rowchk As Range

Dim fromsheet
Dim fromrange
Dim fromfilepath
Dim tofilepath
Dim tofilename
Dim tosheet
Dim torange

Dim pastetypesheet
Dim foundcell
Dim pastetypejp
Dim pastetype

Dim Opnbook As Workbook
Dim fromOpnbook As Workbook
Dim toOpnbook As Workbook
Dim openflg
Dim savefilepath

'設定シート
setsheet = "自動セル転記"
pastetypesheet = "リスト)形式を選択して貼付"

'--------------------
'Main
'--------------------

'他に開いているブックがある場合は中止
For Each Opnbook In Workbooks
If Opnbook.FullName <> ThisWorkbook.FullName Then
MsgBox "安全のため、" & vbCrLf & "他のExcelファイルを全て閉じてから実行してください。"
Exit Sub
End If
Next Opnbook

MsgBox "転記を開始します。"

Application.ScreenUpdating = False '画面チラつき防止

'ログクリア
ThisWorkbook.Sheets(setsheet).Range("N21:N101").ClearContents

cntrow = 21
Do While cntrow < 100
With ThisWorkbook.Sheets(setsheet)

'転記設定の取得
fromfilepath = .Cells(cntrow, 2) & .Cells(cntrow, 3)
fromsheet = .Cells(cntrow, 4)
fromrange = .Cells(cntrow, 5)
tofilepath = .Cells(cntrow, 6) & .Cells(cntrow, 7)
tosheet = .Cells(cntrow, 8)
torange = .Cells(cntrow, 9)
tofilename = .Cells(cntrow, 7)
savefilepath = .Cells(cntrow, 10) & .Cells(cntrow, 11)
.Cells(cntrow, 14) = ""

'セル設定取得
pastetypejp = .Cells(cntrow, 12)
Set foundcell = Worksheets(pastetypesheet).Range("A:A").Find(pastetypejp)
If foundcell Is Nothing Then
pastetype = ""
Else
pastetype = Worksheets(pastetypesheet).Cells(foundcell.Row, 3)
End If

'--------------------
'エラー判定
'--------------------
'--EOF判定(セル範囲が全て空白)
Set rowchk = .Range(.Cells(cntrow, 1), Cells(cntrow, 12))
If WorksheetFunction.CountBlank(rowchk) = rowchk.Count Then
.Cells(cntrow, 14) = "OK)最終行です。"
Exit Do
End If

'--実行対象判定(セル範囲が全て空白)
Set rowchk = .Range(.Cells(cntrow, 1), Cells(cntrow, 1))
If WorksheetFunction.CountBlank(rowchk) = rowchk.Count Then
.Cells(cntrow, 14) = "OK)実行対象外によりスキップしました。"
GoTo Continue
End If

'--転記設定判定(セル範囲に空白が存在)
Set rowchk = .Range(.Cells(cntrow, 2), Cells(cntrow, 12))
If WorksheetFunction.CountBlank(rowchk) <> 0 Then
.Cells(cntrow, 14) = "ERR)設定エラーによりスキップしました。"
GoTo Continue
End If

On Error Resume Next
'--転記元ファイル判定
Open fromfilepath For Append As #1
Close #1
If Err.Number > 0 Then
.Cells(cntrow, 14) = "ERR)実行エラーによりスキップしました。(転記元ファイル)"
GoTo Continue
End If

'--転記先ファイル判定
Open tofilepath For Append As #1
Close #1
If Err.Number > 0 Then
.Cells(cntrow, 14) = "ERR)実行エラーによりスキップしました。(転記先ファイル)"
GoTo Continue
End If

'--保存先ファイル判定(別名保存の場合)
If tofilepath <> savefilepath Then
'ファイルが存在
If Dir(savefilepath) <> "" Then
.Cells(cntrow, 14) = "ERR)実行エラーによりスキップしました。(保存先ファイル)"
GoTo Continue
End If
End If

Application.DisplayAlerts = False 'アラート非表示

On Error GoTo 0
'--ファイル開く
Set fromOpnbook = Workbooks.Open(fromfilepath)
Set toOpnbook = Workbooks.Open(tofilepath)

'--セルをコピぺ
'--(参考)http://www.moug.net/tech/exvba/0050104.html
fromOpnbook.Sheets(fromsheet).Range(fromrange).Copy
toOpnbook.Sheets(tosheet).Range(torange).PasteSpecial Paste:=pastetype
toOpnbook.Sheets(tosheet).Cells(1, 1).Select

'--ファイル保存
If tofilepath = savefilepath Then
toOpnbook.Save
.Cells(cntrow, 14) = "OK)上書保存しました。"
Else
toOpnbook.SaveAs savefilepath
.Cells(cntrow, 14) = "OK)別名保存しました。"
End If

'--ファイル閉じる
fromOpnbook.Close
toOpnbook.Close

Application.DisplayAlerts = True 'アラート表示
End With

Continue:
cntrow = cntrow + 1
Loop

Application.ScreenUpdating = True
MsgBox "転記が完了しました。"

End Sub