From 4dc4b0cc1d5d18b42f6887d0097c63217435c8dc Mon Sep 17 00:00:00 2001
From: Kenichiro NOGI <systemadmin@next-hd.co.jp>
Date: Fri, 11 Sep 2026 13:12:33 +0900
Subject: [PATCH] =?UTF-8?q?feat:=20=E5=8F=96=E5=BE=97=E6=96=B9=E5=BC=8F(D7?=
 =?UTF-8?q?)=E3=82=92=E8=AA=AD=E3=81=BF=E8=BE=BC=E3=82=80fetchMethod?=
 =?UTF-8?q?=E5=A4=89=E6=95=B0=E3=82=92=E8=BF=BD=E5=8A=A0?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 .../vba-files/Module/Module1.bas              | 291 ++++++++++++++++++
 1 file changed, 291 insertions(+)
 create mode 100644 XVBA/新版着工要因閲覧シート/vba-files/Module/Module1.bas

diff --git a/XVBA/新版着工要因閲覧シート/vba-files/Module/Module1.bas b/XVBA/新版着工要因閲覧シート/vba-files/Module/Module1.bas
new file mode 100644
index 00000000..213805f4
--- /dev/null
+++ b/XVBA/新版着工要因閲覧シート/vba-files/Module/Module1.bas
@@ -0,0 +1,291 @@
+Attribute VB_Name = "Module1"
+Option Explicit
+
+Public apiKey As String
+Public baseURL As String
+Public yearFilter As String
+Public tableId As String
+Public defaultSh As Worksheet
+Public fetchMethod As String
+
+Function init()
+    'Pleasanter API KEY
+    apiKey = "6504c8a807677a3a576e10327f3c19876c55736ee45d4a845796b9e7f5e087bfd4bd0d8184863da8cf1733ca635111432ab334aea59102b06a96ee6d2c05190d"
+    baseURL = "https://nextoffice.Next-hd.co.jp"
+    tableId = Range("���H�v��ID")
+
+    Set defaultSh = ThisWorkbook.Sheets("��{���")
+    fetchMethod = defaultSh.Range("D7").Value
+End Function
+
+'******************************************************************************
+Sub run()
+    '����������
+    Call init
+
+    defaultSh.Range("D3").Value = "�捞������..."
+    Application.ScreenUpdating = False '��ʍX�V��~
+    Application.Calculation = xlManual '�����v�Z��~
+    '------------------------------------------
+    Debug.Print "�����J�n"
+
+    'CSV�f�[�^�擾����
+    Dim resData As Variant
+
+    Debug.Print "�f�[�^�擾�����J�n"
+    '�e�[�u����CSV�f�[�^�擾
+    resData = exportCSVData(tableId)
+
+    'resData����̏ꍇ�̓X�L�b�v
+    If IsEmpty(resData) Or resData = "" Then
+        Debug.Print "�f�[�^���擾�ł��܂���ł���"
+    Else
+        'CSV�f�[�^���V�[�g�ɏo��
+        Call exportCSVDataToSheet(resData, tableId)
+    End If
+
+
+    Debug.Print "�����I��"
+    '------------------------------------------
+    Application.Calculation = xlAutomatic '�����v�Z�ĊJ
+    Application.ScreenUpdating = True '��ʍX�V�ĊJ
+    defaultSh.Range("D3").Value = "�捞��������"
+End Sub
+
+'******************************************************************************
+'CSV�f�[�^���擾
+Function exportCSVData(tableId As String) As Variant
+    '���ʕϐ�
+    Dim apiUrl As String
+    Dim apiUrlParam As String
+
+    '���N�G�X�gURL
+    apiUrl = baseURL & "/pleasanter/api/items/" & tableId & "/"
+    apiUrlParam = "export"
+
+    '�w�b�_
+    Dim apiHeaders As New Dictionary
+    apiHeaders.Add "Content-Type", "application/json;charset=utf-8"
+
+    '���N�G�X�g�f�[�^
+    Dim apiBody As New Dictionary
+    apiBody.Add "ApiVersion", "1.1"
+    apiBody.Add "ApiKey", apiKey
+    apiBody.Add "ExportId", "1"
+
+    'Filter�ϐ�
+    'Dim colFilter As New Dictionary
+    'colFilter.Add "ClassZ", "[" & yearFilter & "]"
+
+    'View�ϐ�
+    'Dim view As New Dictionary
+    'view.Add "ColumnFilterHash", colFilter
+    'apiBody.Add "View", view
+
+    'HTTP���N�G�X�g���M���\�b�h�Ăяo��
+    Dim res As Object
+    Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody)
+
+    If res("StatusCode") = 200 Then
+        Debug.Print "CSV�f�[�^�̎擾�ɐ������܂���"
+        exportCSVData = res("Response")("Content")
+
+    End If
+
+End Function
+
+'******************************************************************************
+'CSV�f�[�^���V�[�g�ɏ�������
+Function exportCSVDataToSheet(csvData As Variant, targetSheet As String)
+    Debug.Print "CSV�f�[�^���V�[�g�ɏo�͊J�n: " & targetSheet
+    '------------------------------------------
+    'CSV�f�[�^���u�e�[�u���v�����ɏo�͂��鏈��
+    Dim ws As Worksheet
+    On Error Resume Next
+    Set ws = ThisWorkbook.Sheets(targetSheet)
+    On Error Goto 0
+
+        If ws Is Nothing Then
+            Debug.Print "�V�[�g�����݂��Ȃ����ߐV�K�쐬: " & targetSheet
+            Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
+            ws.Name = targetSheet
+        End If
+
+        'CSV�f�[�^���e�[�u���ɑ}���i�_�u���N�H�[�g���̉��s�E�J���}�ɑΉ�����CSV�p�[�X�j
+        Dim i As Long, j As Long
+        Dim arr() As Variant
+        Dim maxCols As Long
+
+        Dim rows As Collection
+        Set rows = ParseCsv(csvData)
+
+        If rows.count <= 1 Then
+            MsgBox "�f�[�^�����݂��܂���i�w�b�_�̂݁j: " & targetSheet, vbExclamation
+         Exit Function
+        End If
+
+        maxCols = 0
+        Dim rowArr As Variant
+        For Each rowArr In rows
+            If UBound(rowArr) + 1 > maxCols Then
+                maxCols = UBound(rowArr) + 1
+            End If
+        Next rowArr
+
+        ' �񎟌��z���������
+        ReDim arr(0 To rows.count - 1, 0 To maxCols - 1)
+
+        ' �z��Ɋi�[
+        i = 0
+        For Each rowArr In rows
+            For j = LBound(rowArr) To UBound(rowArr)
+                arr(i, j) = rowArr(j)
+            Next j
+            i = i + 1
+        Next rowArr
+
+        '�e�[�u���iListObject�j�擾
+        Dim tbl As ListObject
+        On Error Resume Next
+        Set tbl = ws.ListObjects(targetSheet)
+        On Error Goto 0
+
+            If tbl Is Nothing Then
+                Debug.Print "�e�[�u�������݂��Ȃ����ߐV�K�쐬: " & targetSheet
+                Dim headerRange As Range
+                Set headerRange = ws.Range("A1").Resize(1, maxCols)
+                For j = 0 To maxCols - 1
+                    headerRange.Cells(1, j + 1).Value = arr(0, j)
+                Next j
+                Set tbl = ws.ListObjects.Add(xlSrcRange, headerRange, , xlYes)
+                tbl.Name = targetSheet
+            End If
+
+            '�e�[�u���̃f�[�^�������N���A
+            If Not tbl.DataBodyRange Is Nothing Then
+                tbl.DataBodyRange.ClearContents
+            End If
+
+            ' �e�[�u���Ƀf�[�^��lj��i�w�b�_�s(arr(0,*))���������f�[�^�����݂̂�DataBodyRange�ɏ������ށj
+            tbl.Resize tbl.Range.Resize(rows.count, maxCols)
+
+            Dim dataArr() As Variant
+            ReDim dataArr(1 To rows.count - 1, 1 To maxCols)
+            For i = 1 To rows.count - 1
+                For j = 1 To maxCols
+                    dataArr(i, j) = arr(i, j - 1)
+                Next j
+            Next i
+            tbl.DataBodyRange.Value = dataArr
+
+            '------------------------------------------
+            Debug.Print "CSV�f�[�^���V�[�g�ɏo�͊���: " & targetSheet
+
+End Function
+
+'******************************************************************************
+'CSV��������p�[�X���A�s���Ƃ̃t�B�[���h�z����i�[����Collection��Ԃ�
+'�_�u���N�H�[�g�ň͂܂ꂽ�t�B�[���h���̉��s�E�J���}�E�G�X�P�[�v���ꂽ""�ɑΉ��iRFC4180�����j
+Private Function ParseCsv(Byval csvText As String) As Collection
+    Dim rows As New Collection
+    Dim fields As Collection
+    Set fields = New Collection
+
+    Dim field As String
+    Dim inQuotes As Boolean
+    Dim i As Long, ch As String, nextCh As String
+    Dim textLen As Long
+    textLen = Len(csvText)
+    inQuotes = False
+    field = ""
+
+    i = 1
+    Do While i <= textLen
+        ch = Mid(csvText, i, 1)
+
+        If inQuotes Then
+            If ch = """" Then
+                nextCh = Mid(csvText, i + 1, 1)
+                If nextCh = """" Then
+                    field = field & """"
+                    i = i + 1
+                Else
+                    inQuotes = False
+                End If
+            Else
+                field = field & ch
+            End If
+        Else
+            Select Case ch
+             Case """"
+                inQuotes = True
+             Case ","
+                fields.Add field
+                field = ""
+             Case vbCr, vbLf
+                If ch = vbCr And Mid(csvText, i + 1, 1) = vbLf Then i = i + 1
+                    fields.Add field
+                    field = ""
+                    If Not (fields.count = 1 And fields(1) = "") Then
+                        rows.Add CollectionToArray(fields)
+                    End If
+                    Set fields = New Collection
+                 Case Else
+                    field = field & ch
+                End Select
+            End If
+            i = i + 1
+        Loop
+
+        '�ŏI�t�B�[���h�E�s�i�����ɉ��s�������ꍇ�j
+        If field <> "" Or fields.count > 0 Then
+            fields.Add field
+            rows.Add CollectionToArray(fields)
+        End If
+
+        Set ParseCsv = rows
+End Function
+
+'Collection�i1�����j��0�n�܂��Variant�z��ɕϊ�
+Private Function CollectionToArray(Byval col As Collection) As Variant
+    Dim arr() As Variant
+    ReDim arr(0 To col.count - 1)
+    Dim k As Long
+    For k = 1 To col.count
+        arr(k - 1) = col(k)
+    Next k
+    CollectionToArray = arr
+End Function
+
+'******************************************************************************
+'REST API�ďo����
+'�@method�@Get��POST��
+'�@url�@REST API��URL
+'�@urlParam�@���N�G�X�g�p�����[�^�i�I�v�V�����j
+'�@headers�@�w�b�_�i�I�v�V�����j
+Function callRestApi(Byval method As String, Byval url As String, Optional Byval urlParam As String = "", Optional Byval headers As Dictionary = Null, Optional Byval body As Dictionary = Null) As Object
+
+    'HTTP���N�G�X�g�̃I�u�W�F�N�g���`
+    Dim objHTTP As Object
+    Set objHTTP = New XMLHTTP60
+
+    'HTTP���N�G�X�g�̐ڑ����ݒ�
+    objHTTP.Open method, url & urlParam, False
+
+    '���N�G�X�g�w�b�_�[��ݒ�i��������ꍇ��setRequestHeader�𕡐������Ηǂ��̂��`�j
+    Dim i As Long
+    For i = 0 To headers.count - 1
+        objHTTP.setRequestHeader headers.keys(i), headers.items(i)
+    Next i
+
+    '���N�G�X�g���M
+    objHTTP.send JsonConverter.ConvertToJson(body)
+
+    Do While objHTTP.readyState < 4
+        DoEvents
+    Loop
+
+    '���X�|���X�̕�����iobjHTTP.responseText�j��Json�ɕϊ����ĕԋp
+    Set callRestApi = JsonConverter.ParseJson(objHTTP.responseText)
+
+End Function