ｇｔメモ０２

てすと

'●指定したシート内のセルに変更があった場合実行される
'sheet1をダブルクリックしworksheetとChangeを選択する
'セル1〜15行目1〜3列目に変更があった場合実行
'A1〜A10をコピーしD1へ張り付ける

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row <= 15 And Target.Column <= 3 Then
Range("A1:A10").Copy Range("D1")
End If
End Sub


Private Sub CommandButton1_Click()
If OptionButton1.Value = True Then
Worksheets(1).Range("B2").Value = OptionButton1.Caption
ElseIf OptionButton2.Value = True Then
Worksheets(1).Range("B2").Value = OptionButton2.Caption
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not (Target.Row = 1 And Target.Column = 3) Then End 'C1セルにアクティブしたら次の処理へ
' If Not (Target.Row >= 1 And Target.Column <= 2 And Target.Row >= 2 And Target.Column <= 3) Then End 'B1:C2 内のセルにアクティブしたら次の処理
UserForm1.Show
End Sub

'#If VBA7 Then
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '←64bitではPtrSafeを付けることが重要！
'#Else
'Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
'#End If


プリントスクリーンを実行させるソース
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const KEYEVENTF_EXTENDEDKEY As Long = &H1
Private Const KEYEVENTF_KEYUP As Long = &H2
Private Const fKEYDOWN = KEYEVENTF_EXTENDEDKEY
Private Const fKEYUP = KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP

Sub Sample()
keybd_event vbKeySnapshot, 0&, fKEYDOWN, 0&
keybd_event vbKeySnapshot, 0&, fKEYUP, 0&
'貼り付け処理
End Sub

ファイルを開く
CreateObject("Shell.Application").ShellExecute "C:\Users\Documents\test01.pdf"

Sub PDF読み取り()
CreateObject("Shell.Application").ShellExecute "C:\Users\Documents\test.pdf"
Sleep 1000
SendKeys ("^a"), True
Sleep 500
SendKeys ("^c"), True
Sleep 3000
SendKeys ("^q"), True
Sleep 2000
Windows("vba.xlsm").Activate
Sheets("Sheet4").Activate
Sleep 2000
ActiveSheet.Paste Destination:=Range("B4")
'Sleep 3000
'SendKeys ("^V"), True
End Sub


Sub PDFからTEXT抜き取り()
CreateObject("Shell.Application").ShellExecute "C:\Users\Documents\test01.pdf"
Sleep 3000
SendKeys ("^a"), True
Sleep 500
SendKeys ("^c"), True
Sleep 500
SendKeys ("^q"), True
Sleep 2000
End Sub

Sub CLIPBoard_text_を貼付け()
'PDFファイルからtextを１セルに書き込む為のVBA【PDFからTEXT抜き取り()とセットで使う】
'※ひとつのVBAにするとうまくいかない
Windows("vba.xlsm").Activate
Sheets("Sheet5").Activate
Range("A5").Activate
Sleep 1000
SendKeys "{F2}"
Sleep 500
SendKeys "^v"
'Sleep 2000
SendKeys "{enter}"
'Sleep 2000
End Sub


Sub 最終行列取得テスト()

Dim MaxRow As Long '最終セルの行番号
Dim MaxColumn As Integer '最終セルの列番号

MaxRow = Range("A1").SpecialCells(xlLastCell).Row
MaxColumn = Range("A1").SpecialCells(xlLastCell).Column

MsgBox "最終行は" & MaxRow & "行目" & vbCrLf & _
"最終列は" & MaxColumn & "列目"
End Sub

Sub 隣接使用範囲()
Selection.CurrentRegion.Select '隣接使用範囲(ctrl a)
Sub アクティブセルから使用セル範囲01()
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Font.Color = -16776961　　　’赤色
End Sub

Sub シート内使用全セル範囲02()
ActiveSheet.UsedRange.Select 'シート内使用全セル範囲
End Sub

Sub セル全部指定()
Cells.Select 'セル全部指定(左角)
End Sub

Option Explicit
Sub 平均合計を書き出す()
Dim sum, ave, i As Long
Dim gg, mmm, all As String
Dim MaxRow As Long

MaxRow = Range("A1").SpecialCells(xlLastCell).Row

For i = 2 To MaxRow
gg = "G" & i
mmm = "M" & i
all = gg & ":" & mmm

ave = WorksheetFunction.Average(Range(all)) '平均値
' sum = WorksheetFunction.sum(Range(all))　　　　 '合計

Range("N" & i) = ave
Next i
End Sub

Sub 変更をして書き出す()
Dim i, j As Long
Dim sum, gg, mmm, all, ave ' As String
Dim MaxRow, MaxColumn 'As Long
Dim strData As Long

MaxRow = Range("A1").SpecialCells(xlLastCell).Row
MaxColumn = Range("A1").SpecialCells(xlLastCell).Column

ReDim dall(MaxRow, MaxColumn) 'As Long

'データ開始行を入力
strData = Application.InputBox("ﾃﾞｰﾀ行は" & vbLf & "(必須入力)", "ﾃﾞｰﾀ行は", "2")
For j = strData To MaxRow
For i = 1 To MaxColumn
dall(j, i) = Cells(j, i)
If i = 7 Then
dall(j, i) = dall(j, i) + "1000"
ElseIf dall(j, i) = "A1019" Then 'セル内に"A1019"があったら
dall(j, i) = dall(j, i) & "ggg" '"A1019"に"ggg"を付ける
ElseIf i = 10 Then
dall(j, i) = dall(j, i) & "C"
End If
Next i

Next j
Cells(1, MaxColumn + 1).Resize(MaxRow + 1, MaxColumn + 1).Value = dall
' Range("S1").Resize(MaxRow + 1, MaxColumn + 1).Value = dall
End Sub

Sub クリップボードから書き込み()
Dim buf As String, buf2 As String, CB As New DataObject
' buf = "tanaka"
With CB
' .SetText buf ''変数のデータをDataObjectに格納する
' .PutInClipboard ''DataObjectのデータをクリップボードに格納する
.GetFromClipboard ''クリップボードからDataObjectにデータを取得する
buf2 = .GetText ''DataObjectのデータを変数に取得する
End With
Range("h20") = buf2
MsgBox buf2
End Sub

Sub PDFからTEXT抜き取り→H20ヘ()
CreateObject("Shell.Application").ShellExecute "C:\Users\Documents\test02.pdf"
Sleep 5000
SendKeys ("^a"), True
Sleep 1000
SendKeys ("^c"), True
Sleep 2000
SendKeys ("^q"), True
Sleep 2000
Dim buf As String, buf2 As String, CB As New DataObject
CB.GetFromClipboard ''クリップボードからDataObjectにデータを取得する
buf2 = CB.GetText ''DataObjectのデータを変数に取得する
Range("h22") = buf2
MsgBox buf2
End Sub

http://officetanaka.net/excel/vba/speed/s15.htm

Sub Macro4()
Dim buf As String, A As Variant, i As Long, j As Long
ReDim B(99999, 4)
Open "C:\Data\Work\sample.csv" For Input As #1
Do Until EOF(1)
Line Input #1, buf
A = Split(buf, ",")
For j = 0 To UBound(A)
B(i, j) = A(j)
Next j
i = i + 1
Loop
Close #1
Range("A1").Resize(100000, 5) = B ''1回だけ代入
End Sub

Dim Amax, Bmax, Cmax As String
Dim stn(50)
For i = 11 To Sheets.Count
stn(i) = Sheets(i).Name
If Mid(stn(i), 1, 1) = "A" Then Amax = Mid(stn(i), 2, 2)
If Mid(stn(i), 1, 1) = "B" Then Bmax = Mid(stn(i), 2, 2)
If Mid(stn(i), 1, 1) = "C" Then Cmax = Mid(stn(i), 2, 2)
Next i
' For j = 1 To 3
Cells(1, 11) = "A" & Format(Amax + 1, "00") 'sheet.Cells(1,1).Value = Format(cnt,"000")
Cells(2, 11) = "B" & Format(Bmax + 1, "00")
Cells(3, 11) = "C" & Format(Cmax + 1, "00")
' Next j
End Sub

bin2csv_v2.exe 1 3 3 C:\Users\DIST\Documents\長渕\20200526\bk\3010_201910101507.bin .\ss\

Sub format変更()

Dim i As Long
Dim gyou As Long
Dim dd(21) As String
Worksheets("format").Activate
Worksheets("format").Copy After:=Worksheets(Worksheets.Count)
Range("D3:H17").ClearContents
gyou = Range("B23")
For i = 1 To 21
dd(i) = Cells(gyou, i)
Next i
If Mid(dd(13), 1, 1) = "A" Then GoTo A_No
If Mid(dd(1), 1, 1) = "B" Then GoTo B_No
If Mid(dd(1), 1, 1) = "C" Then GoTo C_No
Exit Sub
A_No:
Range("D3") = Mid(dd(13), 1, 3) 'A_No.
Range("D4") = "実証実験関連" 'A_ｶﾃｺﾞﾘｰ
Range("D5") = dd(8) 'A_ﾀｲﾄﾙ
Range("D6") = dd(6) 'A_発生日
Range("D7") = dd(5) & " ※　D8から要追加" 'A_出所
Range("D8") = dd(9) 'A_質問
Range("D9") = dd(10) 'A_回答
Range("D11") = dd(18) 'A_対策内容
Range("E12") = "リリース" 'リリース
Range("G12") = "重要度" '重要度
Range("H12") = dd(15) 'A_重要度
Range("D13") = "顧客名 : " & dd(11) & " : " & dd(12) '備考
Range("D14") = dd(17) 'A_対処完了
Range("D15") = dd(19) 'A_格納ホルダー
Range("D16") = dd(20) 'A_原因種別
Range("D17") = dd(21) 'A_状態
Range("D7").WrapText = False
Range("D15").WrapText = False
ActiveSheet.Name = Mid(dd(13), 1, 3)
Range("20:100").Delete
Worksheets("format").Activate
Exit Sub
B_No:
Range("D3") = Mid(dd(1), 1, 3) 'B_No.
Range("D4") = "ユーザの声" 'B_ｶﾃｺﾞﾘｰ
Range("D5") = dd(9) 'B_ﾀｲﾄﾙ
Range("D6") = "2020/" & dd(2) & "/" & dd(3) 'B_発生日
Range("D7") = dd(6) 'B_出所
Range("D8") = dd(7) 'B_内容
Range("E12") = dd(11) 'B_重要度
Range("D11") = dd(12) 'B_対策内容
Range("H12") = "リリース" 'リリース
Range("G12") = "重要度" '重要度
Range("D13") = "年齢 : " & dd(5) & " 性別 : " & dd(4) 'B_備考
Range("D14") = dd(13) 'B_対処完了
Range("D15") = dd(14) 'B_格納ホルダー
Range("D16") = dd(15) 'B_原因種別
Range("D17") = dd(16) 'B_状態
Range("D7").WrapText = False
Range("D15").WrapText = False
ActiveSheet.Name = Mid(dd(1), 1, 3)
Range("20:100").Delete
Worksheets("format").Activate
Exit Sub
C_No:
Range("D3") = Mid(dd(1), 1, 3) 'C_No.
Range("D4") = "その他調査" 'C_ｶﾃｺﾞﾘｰ
Range("D5") = dd(3) 'C_ﾀｲﾄﾙ
Range("D6") = dd(4) 'C_発生日
Range("D7") = dd(5) 'C_出所
Range("D8") = dd(7) 'C_内容
Range("H12") = dd(11) 'C_重要度
Range("D11") = dd(12) 'C_対策内容
Range("E12") = "リリース" 'リリース
Range("G12") = "重要度" '重要度
Range("D14") = dd(13) 'C_対処官僚
Range("D15") = dd(14) 'C_格納ホルダー
Range("D16") = dd(15) 'C_原因種別
Range("D17") = dd(16) 'C_状態
Range("D7").WrapText = False
Range("D15").WrapText = False
ActiveSheet.Name = Mid(dd(1), 1, 3)
Range("20:100").Delete
Worksheets("format").Activate
Exit Sub
End Sub

Sub binaCSV条件で抽出()
Dim Fname As String
Dim PathName As String
Dim StartRow As Integer
Dim FileNo As Integer
Dim TextLine As String
Dim dat() As String
Dim i, f, fa, ff As Long
i = 0

' PathName = ThisWorkbook.path & "\copyファイル\ss\"
' PathName = "C:\Users\DIST\Documents\長渕\20200526\"
PathName = "C:\Users\DIST\Documents\長渕\リンクデータ\20200401_0630\"
Fname = Dir(PathName & "5001_20200???.csv")
Do While Fname <> ""
FileNo = FreeFile()
Open PathName & Fname For Input As #FileNo
Range("on1") = Fname
Line Input #FileNo, TextLine
dat() = Split(TextLine, ",")
On Error Resume Next
' If dat(0) = "Aメッシュ" Then
' For ff = 1 To 392
' Cells(3, ff).Value = dat(ff - 1)
' Next ff
' Else
' End If
StartRow = 3
Do Until EOF(FileNo)
Line Input #FileNo, TextLine
dat() = Split(TextLine, ",")
On Error Resume Next
' If Dat(0) = "533935" And Dat(2) = "1261" _
' Then ' ※下記一覧参照Dat()内は0から始まる
''---533935-39 _1454_ _1455_ _804_ _1257_ _1258_ _1399_ _1400_ _1401_ _1402_
' If Dat(0) = "533935" And Dat(2) = "1454" _
' Or Dat(0) = "533935" And Dat(2) = "1455" _
' Or Dat(0) = "533935" And Dat(2) = "804" _
' Or Dat(0) = "533935" And Dat(2) = "1257" _
' Or Dat(0) = "533935" And Dat(2) = "1258" _
' Or Dat(0) = "533935" And Dat(2) = "1399" _
' Or Dat(0) = "533935" And Dat(2) = "1400" _
' Or Dat(0) = "533935" And Dat(2) = "1401" _
' Or Dat(0) = "533935" And Dat(2) = "1402" _
' Then ' ※下記一覧参照Dat()内は0から始まる
'---533955-19 _1019_ _1020_ _1021_ _1022_ _1014_
' If dat(0) = "533955" And dat(2) = "1019" _
' Or dat(0) = "533955" And dat(2) = "1020" _
' Or dat(0) = "533955" And dat(2) = "1021" _
' Or dat(0) = "533955" And dat(2) = "1022" _
' Or dat(0) = "533955" And dat(2) = "1014" _
' Then ' ※下記一覧参照Dat()内は0から始まる

'---533945-99 _302_ _301_ _1161_ _1162_ _299_ _298_
' If Dat(0) = "533945" And Dat(2) = "302" _
' Or Dat(0) = "533945" And Dat(2) = "301" _
' Or Dat(0) = "533945" And Dat(2) = "1161" _
' Or Dat(0) = "533945" And Dat(2) = "1162" _
' Or Dat(0) = "533945" And Dat(2) = "299" _
' Or Dat(0) = "533945" And Dat(2) = "298" _
' Then ' ※下記一覧参照Dat()内は0から始まる

If dat(0) = "Aメッシュ" Then
GoTo del
ElseIf dat(11) = 2 Then '※下記一覧参照Dat()内は0から始まる
For ff = 1 To 392
Cells(StartRow + i, 390).NumberFormatLocal = "0"
Cells(StartRow + i, 391).NumberFormatLocal = "0"
Cells(StartRow + i, 392).NumberFormatLocal = "0"
Cells(StartRow + i, ff).Value = dat(ff - 1)
Next ff
i = i + 1
Else
del:
End If
Loop
Close #FileNo
Fname = Dir()
Loop

Sub format変更()

Dim i As Long
Dim gyou As Long
Dim dd(21) As String
'Dim format As Worksheet
Worksheets("format").Copy After:=Worksheets(Worksheets.Count)
Range("D3:H17").ClearContents
gyou = Range("B20")
For i = 1 To 21
dd(i) = Cells(gyou, i)
Next i
If Mid(dd(13), 1, 1) = "A" Then GoTo A_No
If Mid(dd(1), 1, 1) = "B" Then GoTo B_No
If Mid(dd(1), 1, 1) = "C" Then GoTo C_No
Exit Sub
A_No:
Range("D3") = Mid(dd(13), 1, 3) 'A_No.
Range("D4") = "実証実験関連" 'A_ｶﾃｺﾞﾘｰ
Range("D5") = dd(8) 'A_ﾀｲﾄﾙ
Range("D6") = dd(6) 'A_発生日
Range("D7") = dd(5) & " ※　D8から要追加" 'A_出所
Range("D8") = dd(9) 'A_質問
Range("D9") = dd(10) 'A_回答
Range("D11") = dd(18) 'A_対策内容
Range("E12") = "リリース" 'リリース
Range("G12") = "重要度" '重要度
Range("H12") = dd(15) 'A_重要度
Range("D13") = "顧客名 : " & dd(11) & " : " & dd(12) '備考
Range("D14") = dd(17) 'A_対処完了
Range("D15") = dd(19) 'A_格納ホルダー
Range("D16") = dd(20) 'A_原因種別
Range("D17") = dd(21) 'A_状態
Range("D7").WrapText = False
Range("D15").WrapText = False
ActiveSheet.Name = Mid(dd(13), 1, 3)
Range("20:100").Delete
' ActiveSheet.Buttons.Delete
Worksheets("format").Activate
Exit Sub
B_No:
Range("D3") = Mid(dd(1), 1, 3) 'B_No.
Range("D4") = "ユーザの声" 'B_ｶﾃｺﾞﾘｰ
Range("D5") = dd(9) 'B_ﾀｲﾄﾙ
Range("D6") = "2020/" & dd(2) & "/" & dd(3) 'B_発生日
Range("D7") = dd(6) 'B_出所
Range("D8") = dd(7) 'B_内容
Range("E12") = dd(11) 'B_重要度
Range("D11") = dd(12) 'B_対策内容
Range("H12") = "リリース" 'リリース
Range("G12") = "重要度" '重要度
Range("D13") = "年齢 : " & dd(5) & " 性別 : " & dd(4) 'B_備考
Range("D14") = dd(13) 'B_対処完了
Range("D15") = dd(14) 'B_格納ホルダー
Range("D16") = dd(15) 'B_原因種別
Range("D17") = dd(16) 'B_状態
Range("D7").WrapText = False
Range("D15").WrapText = False
ActiveSheet.Name = Mid(dd(1), 1, 3)
Range("20:100").Delete
Worksheets("format").Activate
Exit Sub
C_No:
Range("D3") = Mid(dd(1), 1, 3) 'C_No.
Range("D4") = "その他調査" 'C_ｶﾃｺﾞﾘｰ
Range("D5") = dd(3) 'C_ﾀｲﾄﾙ
Range("D6") = dd(4) 'C_発生日
Range("D7") = dd(5) 'C_出所
Range("D8") = dd(7) 'C_内容
Range("H12") = dd(11) 'C_重要度
Range("D11") = dd(12) 'C_対策内容
Range("E12") = "リリース" 'リリース
Range("G12") = "重要度" '重要度
Range("D14") = dd(13) 'C_対処官僚
Range("D15") = dd(14) 'C_格納ホルダー
Range("D16") = dd(15) 'C_原因種別
Range("D17") = dd(16) 'C_状態
Range("D7").WrapText = False
Range("D15").WrapText = False
ActiveSheet.Name = Mid(dd(1), 1, 3)
Range("20:100").Delete
Worksheets("format").Activate
Exit Sub
'Dim i As Long
'For i = 1 To Worksheets.Count
' Cells(i, 1) = Worksheets(i).Name
'Next
End Sub

Sub シート作成()
Dim Amax, Bmax, Cmax As String
Dim stn(1000)
Dim buf As String, msg As String
Worksheets("format").Activate

For i = 1 To Sheets.Count
stn(i) = Sheets(i).Name
If Mid(stn(i), 1, 1) = "A" And Amax < Mid(stn(i), 2, 2) Then Amax = Mid(stn(i), 2, 2)
If Mid(stn(i), 1, 1) = "B" And Bmax < Mid(stn(i), 2, 2) Then Bmax = Mid(stn(i), 2, 2)
If Mid(stn(i), 1, 1) = "C" And Cmax < Mid(stn(i), 2, 2) Then Cmax = Mid(stn(i), 2, 2)
Next i
msg = "シート作成をいたします" & vbCrLf & "a･b･cを半角1文字のみを入力" & vbCrLf & vbCrLf & _
"a は [実証実験関連] (" & "A" & format(Amax + 1, "00") & ")" & vbCrLf & _
"b は [ユーザの声]　 　(" & "B" & format(Bmax + 1, "00") & ")" & vbCrLf & _
"c は [その他調査]　 　(" & "C" & format(Cmax + 1, "00") & ")" & vbCrLf
buf = InputBox(msg)
If buf = "a" Then
Worksheets("format").Copy After:=Worksheets(Worksheets.Count)
' Range("D3:H17").ClearContents
ActiveSheet.Name = "A" & format(Amax + 1, "00")
Range("d3") = "A" & format(Amax + 1, "00")
Range("d4") = "実証実験関連"
Range("K:P").Delete
Range("A1").Activate
ElseIf buf = "b" Then
Worksheets("format").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "B" & format(Bmax + 1, "00")
Range("d3") = "B" & format(Bmax + 1, "00")
Range("d4") = "ユーザの声"
Range("K:P").Delete
Range("A1").Activate
ElseIf buf = "c" Then
Worksheets("format").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "C" & format(Cmax + 1, "00")
Range("d3") = "C" & format(Cmax + 1, "00")
Range("d4") = "その他調査"
Range("K:P").Delete
Range("A1").Activate
Else
MsgBox "確認が出来ません　" & vbCrLf & "OK押し,再度シート作成を押してください"
Range("A1").Activate
End If

End Sub
Sub 問題連絡票_一覧_へ戻る()
Worksheets("問題連絡票（一覧）").Activate
Range("A1").Activate
End Sub
Sub シート名作成()
Dim i, j, A01 As Long
Dim stn(1000) As String

Worksheets("問題連絡票（一覧）").Activate

For i = 1 To Sheets.Count
stn(i) = Worksheets(i).Name
If stn(i) = "A01" Then A01 = i
Next i
jj = i
For j = A01 To jj - 1
ActiveSheet.Hyperlinks.Add Anchor:=Cells(j - A01 + 4, "B"), _
Address:="", SubAddress:=stn(j) & "!A1", TextToDisplay:=stn(j)
Next j
Range("A1").Activate
End Sub

Sub jsonCSV_drmrink指定で抜き出す03()
Dim Fname, PathName, TextLine As String
Dim StartRow, FileNo As Integer
Dim d, i, dd, ff, k, Result As Long
Dim a1d As String
Dim Dat() As String
Dim drmt(50) 'As String
Dim MaxCol, MaxColt As Integer
UserForm1.Show
If Range("A1") = "" Or Range("A2") = "" Or Range("B1") = "" Or Range("B2") = "" Then
MsgBox ("入力データ不足です " & vbCrLf & "A1は mesh" & vbCrLf & "A2-右へdrm 2個以上" & vbCrLf & _
"B1-抽出ディレクトリ" & vbCrLf & "C1-右へ時間(空白は全て)")
Exit Sub
End If
If Range("A5") <> "" Then
Result = MsgBox("前回のデータがあります" & vbCrLf & "中断しますか？", vbYesNo + vbExclamation)
If Result = vbYes Then
Exit Sub
Else
Range("A5", Range("A5").SpecialCells(xlLastCell)).Clear
End If
End If
If Range("c1") <> "" Then
MaxColt = Range("C1").End(xlToRight).Column
For d = 1 To MaxColt - 2
drmt(d) = Cells(1, d + 2).Value
' Cells(1, d + 17) = drmt(d) '確認用　読み込んだ日時書き出し
Next d
End If
MaxCol = Range("A2").End(xlToRight).Column
ReDim drm(MaxCol), drm1(MaxCol) As String

For d = 1 To MaxCol
drm1(d) = Cells(2, d).Value
Cells(3, d).NumberFormatLocal = "@"
drm1(d) = Format(drm1(d), "00000")
If d >= 2 Then
rm(d) = drm1(d - 1) & drm1(d)
End If
Next d
a1d = Left(Cells(1, 1), 6) '　メッシュNo
i = 0
' PathName = "C:\Users\DIST\Documents\長渕\20200519\533946-2-240\json\"
PathName = Range("B1").Value
Fname = Dir(PathName & "*.json.csv")
Do While Fname <> ""
FileNo = FreeFile()
Open PathName & Fname For Input As #FileNo
Line Input #FileNo, TextLine
Dat() = Split(Replace(TextLine, """", ""), ",")
For ff = 1 To 10
Cells(4, ff).Value = Dat(ff - 1)
Next ff
Cells(4, ff + 1).Value = "ﾒｰｶｰNo"
Cells(4, ff + 2).Value = "t年月日"
Cells(4, ff + 3).Value = "t時間"
Cells(4, ff + 4).Value = "f時間"
Cells(4, ff + 5).Value = "fname"
StartRow = 5
Do Until EOF(FileNo)
Line Input #FileNo, TextLine
TextLine = Replace(TextLine, """", "")
TextLine = Replace(TextLine, "-", "/")

Dat() = Split(TextLine, ",")

If drmt(1) = "" Then
For dd = 1 To MaxCol
If Dat(0) = a1d And Dat(1) = drm(dd) Then
GoSub 書き込み01
End If
Next dd
End If
For k = 1 To MaxColt - 2
For d = 1 To MaxCol
If Dat(0) = a1d And Dat(1) = drm(d - 1) And Dat(2) = drmt(k) Then
GoSub 書き込み01
End If
Next d
Next k
d = 0
Loop
Close #FileNo
Fname = Dir()
Loop
Exit Sub

書き込み01:
Cells(StartRow + i, 2).NumberFormatLocal = "@"
Cells(StartRow + i, 3).NumberFormatLocal = "@"
For ff = 1 To 10
Cells(StartRow + i, ff).Value = Dat(ff - 1)
Next ff
Cells(StartRow + i, ff + 1).NumberFormatLocal = "000" 'ﾒｰｶｰNo
Cells(StartRow + i, ff + 2).NumberFormatLocal = "@" 'drm年月日
Cells(StartRow + i, ff + 3).NumberFormatLocal = "hh:mm" 'drm時間
Cells(StartRow + i, ff + 4).NumberFormatLocal = "hh:mm" '
Cells(StartRow + i, ff + 1).Value = Mid(Fname, 1, 3) 'ﾒｰｶｰNo
Cells(StartRow + i, ff + 2).Value = Mid(Dat(2), 1, 10) 'd年月日
Cells(StartRow + i, ff + 3).Value = Mid(Dat(2), 12, 5) 'd時間
Cells(StartRow + i, ff + 4).Value = Mid(Fname, 13, 2) & ":" & Mid(Fname, 15, 2) '
Cells(StartRow + i, ff + 5).Value = Fname
i = i + 1
Return
End Sub

Option Explicit

Sub jsonCSV_drmrink指定で抜き出す()
Dim Fname As String
Dim PathName As String
Dim StartRow As Integer
Dim FileNo As Integer
Dim TextLine As String
Dim i As Long
Dim ff As Long
Dim Dat() As String
Dim a1d, b1d, c1d, d1d, e1d, f1d, g1d '抜き出しキー
a1d = Cells(1, 1) '　メッシュNo
b1d = Cells(1, 2) '　区分
c1d = Cells(1, 3) '　drmlinkNo (1)
d1d = Cells(1, 4) '　drmlinkNo (2)
e1d = Cells(1, 5) '　drmlinkNo (3)
f1d = Cells(1, 6) '
g1d = Cells(1, 7) '　日時
i = 0

' PathName = ThisWorkbook.path & "\リンクデータ\JSON\test\"
PathName = "C:\Users\DIST\Documents\長渕\リンクデータ\JSON\解凍ファイル\"
Fname = Dir(PathName & "*.json.csv")
Do While Fname <> ""
FileNo = FreeFile()
Open PathName & Fname For Input As #FileNo
Line Input #FileNo, TextLine
Dat() = Split(TextLine, ",")
' On Error Resume Next
' If Dat(0) = "meshcode" Then
For ff = 1 To 10
Cells(2, ff).Value = Dat(ff - 1)
Next ff
Cells(2, ff + 1).Value = "filename"
' Else
' End If
StartRow = 3
Do Until EOF(FileNo)
Line Input #FileNo, TextLine
Dat() = Split(TextLine, ",")
' On Error Resume Next
' If Dat(0) = "533935" And Dat(1) = "231105422" Then '
If g1d <> "" Then
GoTo sss1

ElseIf Dat(0) = a1d And Dat(1) = b1d Then
For ff = 1 To 10
Cells(StartRow + i, ff).Value = Dat(ff - 1)
Next ff
Cells(StartRow + i, ff + 1).Value = Fname
i = i + 1
ElseIf Dat(0) = a1d And Dat(1) = c1d Then '
For ff = 1 To 10
Cells(StartRow + i, ff).Value = Dat(ff - 1)
Next ff
Cells(StartRow + i, ff + 1).Value = Fname
i = i + 1
ElseIf Dat(0) = a1d And Dat(1) = d1d Then '
For ff = 1 To 10
Cells(StartRow + i, ff).Value = Dat(ff - 1)
Next ff
Cells(StartRow + i, ff + 1).Value = Fname
i = i + 1
ElseIf Dat(0) = a1d And Dat(1) = e1d Then '
For ff = 1 To 10
Cells(StartRow + i, ff).Value = Dat(ff - 1)
Next ff
Cells(StartRow + i, ff + 1).Value = Fname
i = i + 1
Else
sss1:
If Dat(0) = a1d And Dat(1) = b1d And Dat(2) = g1d Then
For ff = 1 To 10
Cells(StartRow + i, ff).Value = Dat(ff - 1)
Next ff
Cells(StartRow + i, ff + 1).Value = Fname
i = i + 1
ElseIf Dat(0) = a1d And Dat(1) = c1d And Dat(2) = g1d Then
For ff = 1 To 10
Cells(StartRow + i, ff).Value = Dat(ff - 1)
Next ff
Cells(StartRow + i, ff + 1).Value = Fname
i = i + 1
ElseIf Dat(0) = a1d And Dat(1) = d1d And Dat(2) = g1d Then
For ff = 1 To 10
Cells(StartRow + i, ff).Value = Dat(ff - 1)
Next ff
Cells(StartRow + i, ff + 1).Value = Fname
i = i + 1
ElseIf Dat(0) = a1d And Dat(1) = e1d And Dat(2) = g1d Then
For ff = 1 To 10
Cells(StartRow + i, ff).Value = Dat(ff - 1)
Next ff
Cells(StartRow + i, ff + 1).Value = Fname
i = i + 1
End If
End If
Loop
Close #FileNo
Fname = Dir()
Loop
End Sub

Sub jsonCSV_drmrink指定で抜き出す02()
Dim Fname As String
Dim PathName As String
Dim StartRow As Integer
Dim FileNo As Integer
Dim TextLine As String
Dim d, i, dd As Long
Dim ff As Long
Dim Dat() As String
Dim a1d, b1d, c1d, d1d, e1d, f1d, g1d 'As Integer '抜き出しキー
Dim MaxCol As Integer
' MaxRow = Range("A1").End(xlDown).Row
MaxCol = Range("A2").End(xlToRight).Column
ReDim drm(MaxCol) As String
For d = 1 To MaxCol
drm(d) = Cells(2, d).Value
Next d

a1d = Cells(1, 1) '　メッシュNo
b1d = Cells(1, 2) '　区分
c1d = Cells(1, 3) '　drmlinkNo (1)
d1d = Cells(1, 4) '　drmlinkNo (2)
e1d = Cells(1, 5) '　drmlinkNo (3)
f1d = Cells(1, 6) '
g1d = Cells(1, 7) '　日時
i = 0

' PathName = ThisWorkbook.path & "\リンクデータ\JSON\test\"
PathName = "C:\Users\DIST\Documents\長渕\20200519\533915-1-43\json\"
Fname = Dir(PathName & "*.json.csv")
Do While Fname <> ""
FileNo = FreeFile()
Open PathName & Fname For Input As #FileNo
Line Input #FileNo, TextLine
Dat() = Split(TextLine, ",")
For ff = 1 To 10
Cells(4, ff).Value = Dat(ff - 1)
Next ff
Cells(4, ff + 1).Value = "filename"
StartRow = 5
Do Until EOF(FileNo)
Line Input #FileNo, TextLine
Dat() = Split(TextLine, ",")
If g1d = "" Then
' GoTo sss1
For dd = 1 To MaxCol
If Dat(0) = a1d And Dat(1) = drm(dd) Then
For ff = 1 To 10
Cells(StartRow + i, ff).Value = Dat(ff - 1)
Next ff
Cells(StartRow + i, ff + 1).Value = Fname
i = i + 1
' Else
End If
Next dd
End If

'sss1:
For d = 1 To MaxCol
If Dat(0) = a1d And Dat(1) = drm(d - 1) And Dat(2) = g1d Then

For ff = 1 To 10
Cells(StartRow + i, ff).Value = Dat(ff - 1)
Next ff
Cells(StartRow + i, ff + 1).Value = Fname
i = i + 1
' Else
End If
Next d
d = 0
Loop
Close #FileNo
Fname = Dir()
Loop
End Sub

Option Explicit

Sub binaCSV_必要項目を書き出す()
Dim Fname As String
Dim PathName As String
Dim StartRow As Integer
Dim FileNo As Integer
Dim TextLine As String
Dim Dat() As String
Dim i, f, fa, ff As Long
i = 0

PathName = ThisWorkbook.path & "\copyファイル\ss\"
Fname = Dir(PathName & "*.bina.csv")
Do While Fname <> ""
FileNo = FreeFile()
Open PathName & Fname For Input As #FileNo
Line Input #FileNo, TextLine
Dat() = Split(TextLine, ",")
On Error Resume Next
If Dat(0) = "Aメッシュ" Then
' Cells(1, 1).Resize(, 83).Value = Dat()
For ff = 1 To 392
Cells(3, ff).Value = Dat(ff - 1)
Next ff
' For ff = 1 To 83
' Cells(3, ff).Value = Dat(ff - 1)
' Next ff
' For f = 369 To 390
' fa = f - 369
' Cells(3, 84 + fa).Value = Dat(f)
' Next f
Else
End If
StartRow = 4
Do Until EOF(FileNo)
Line Input #FileNo, TextLine
Dat() = Split(TextLine, ",")
On Error Resume Next
If Dat(36) > 1000 Then 'And Dat(2) = "27" ThenAK列(36)ELTT旅行時間　1000以上
For ff = 1 To 392
Cells(StartRow + i, ff).Value = Dat(ff - 1)
Next ff
' For ff = 1 To 83
' Cells(StartRow + i, ff).Value = Dat(ff - 1)
' Next ff
' For f = 369 To 390
' fa = f - 369
' Cells(StartRow + i, 84 + fa).Value = Dat(f)
' Next f
i = i + 1
Else
End If
Loop
Close #FileNo
Fname = Dir()
Loop

=IF(M4="","",IFNA(INDEX(ソフト変更履歴!$B$4:$H$50,MATCH(INDIRECT(LEFT(M4,3)&"!$D$16"),ソフト変更履歴!$E$4:$E$50,0),5),""))

Sub foo()
Dim x As Workbook
Dim y As Workbook
'## Open both workbooks first:
Set x = Workbooks.Open("C:\Users\bt\Documents\xlsテスト001.xlsm")
Set y = Workbooks.Open("C:\Users\bt\Documents\zu\01-a.xlsx")
'Now, copy what you want from x:
x.Sheets("01-a").Cells.Copy
'Now, paste to y worksheet:
y.Sheets("sss").Range("A1").PasteSpecial Paste:=xlPasteValues
y.Sheets("sss").Range("A1").Select
'Close x:
' x.Close
End Sub


Sub foo2 ()
Dim x As Workbook
Dim y As Workbook
'## Open both workbooks first:
Set x = Workbooks.Open ("C:\Users\bt\Documents\xlsテスト001.xlsm")
Set y = Workbooks.Open ("C:\Users\bt\Documents\zu\01-a.xlsx")
'Now, transfer values from x to y:
y.Sheets ("sss").Range ("A1").Resize (x.Sheets ("01-a").UsedRange.Rows.Count, x.Sheets ("01-a").UsedRange.Columns.Count).Value = x.Sheets ("01-a").UsedRange.Value
'Close x:
End Sub