{"id":18718,"date":"2026-01-22T06:00:00","date_gmt":"2026-01-21T21:00:00","guid":{"rendered":"https:\/\/www.muscle-hypertrophy.com\/?p=18718"},"modified":"2026-01-20T07:31:23","modified_gmt":"2026-01-19T22:31:23","slug":"%e5%9c%b0%e6%96%b9%e5%8e%9a%e7%94%9f%e5%b1%80%e3%81%ae%e3%82%b3%e3%83%bc%e3%83%89%e5%86%85%e5%ae%b9%e5%88%a5%e5%8c%bb%e7%99%82%e6%a9%9f%e9%96%a2%e4%b8%80%e8%a6%a7%e8%a1%a8%e3%81%8b%e3%82%89%e5%8c%bb","status":"publish","type":"post","link":"https:\/\/www.muscle-hypertrophy.com\/?p=18718","title":{"rendered":"\u5730\u65b9\u539a\u751f\u5c40\u306e\u30b3\u30fc\u30c9\u5185\u5bb9\u5225\u533b\u7642\u6a5f\u95a2\u4e00\u89a7\u8868\u304b\u3089\u533b\u7642\u6a5f\u95a2\u306e\u8a3a\u7642\u79d1\u3092\u53d6\u5f97\u3059\u308b"},"content":{"rendered":"\n

\u3000\u5148\u306e\u8a18\u4e8b\u3067\u306f\u5168\u56fd\u306e\u533b\u7642\u6a5f\u95a2\u306e\u533b\u7642\u6a5f\u95a2\u30b3\u30fc\u30c9\u3092\u53d6\u5f97\u3057\u305f\uff0e\u4eca\u56de\u306f\u5168\u56fd\u306e\u533b\u7642\u6a5f\u95a2\u306e\u8a3a\u7642\u79d1\u3092\u53d6\u5f97\u3057\uff0c\u7b2c\u4e00\u6b63\u898f\u5f62\u306b\u3059\u308b\u3068\u3053\u308d\u307e\u3067\u3092\u89e3\u8aac\u3059\u308b\uff0e<\/p>\n

\u3000\u4eca\u56de\u304b\u3089\u751f\u6210AI\u3092\u30b3\u30fc\u30c7\u30a3\u30f3\u30b0\u306e\u88dc\u52a9\u3068\u3057\u3066\u4f7f\u7528\u3059\u308b\u3053\u3068\u3092\u304a\u65ad\u308a\u3057\u3066\u304a\u304f\uff0e<\/p>\n

<\/p>\n

\u30c7\u30fc\u30bf\u306e\u53d6\u5f97<\/h2>\n

\u3000\u30c7\u30fc\u30bf\u306e\u53d6\u5f97\u306f\u5730\u65b9\u539a\u751f\u5c40<\/a>\u304b\u3089\u59cb\u3081\u308b\uff0e\u5404\u5730\u65b9\u539a\u751f\u5c40\u306e\u30b5\u30a4\u30c8\u306e\u691c\u67fb\u6b04\u306b\u300c\u30b3\u30fc\u30c9\u5185\u5bb9\u5225\u533b\u7642\u6a5f\u95a2\u4e00\u89a7\u8868\u300d\u3068\u5165\u529b\u3057\u3066\u51fa\u3066\u304d\u305f\u4e00\u756a\u76ee\u306b\u8a72\u5f53\u30da\u30fc\u30b8\u304c\u3042\u308b\uff0e\u30d5\u30a1\u30a4\u30eb\u306e\u7f6e\u304d\u5834\u6240\uff0c\u69cb\u9020\u306f8\u3064\u306e\u5730\u65b9\u539a\u751f\u5c40\u305d\u308c\u305e\u308c\u306b\u3088\u3063\u3066\u7570\u306a\u308b\uff0e\u4e0b\u56f3\u306f\u4e5d\u5dde\u539a\u751f\u5c40\u306e\u30b5\u30a4\u30c8\u3067\u3042\u308b\uff0e\u30a8\u30af\u30bb\u30eb\u30c7\u30fc\u30bf\u3092\u30c0\u30a6\u30f3\u30ed\u30fc\u30c9\u3059\u308b\uff0e<\/p>\n

\"\u4e5d\u5dde\u539a\u751f\u5c40\u306e\u30b3\u30fc\u30c9\u5185\u5bb9\u5225\u533b\u7642\u6a5f\u95a2\u4e00\u89a7\u8868\"<\/a>
\u4e5d\u5dde\u539a\u751f\u5c40\u306e\u30b3\u30fc\u30c9\u5185\u5bb9\u5225\u533b\u7642\u6a5f\u95a2\u4e00\u89a7\u8868<\/figcaption><\/figure>\n

Power Query\u3067\u5730\u65b9\u539a\u751f\u5c40\u3054\u3068\u306b\u30c7\u30fc\u30bf\u3092\u96c6\u7d04\u3059\u308b<\/h2>\n

\u3000\u4e5d\u5dde\u306e8\u770c\u306e\u30d5\u30a1\u30a4\u30eb\u3092\u539a\u751f\u5c40\u3054\u3068\uff0c\u533b\u79d1\u3068\u6b6f\u79d1\u3054\u3068\u306b\u30d5\u30a9\u30eb\u30c0\u306b\u5206\u3051\u308b\uff0e\u307e\u3068\u3081\u3066Power Query\u3067\u51e6\u7406\u3057\u305f\u304f\u306a\u308b\u304c\uff0c\u30a8\u30e9\u30fc\u306b\u3088\u308a\u5168\u56fd\u4e00\u62ec\u8aad\u307f\u8fbc\u307f\u306f\u4e0d\u53ef\u80fd\u3067\u3042\u308b\uff0e\u5730\u65b9\u539a\u751f\u5c40\u3054\u3068\u306b\u8aad\u307f\u8fbc\u3080\u306e\u304c\u305b\u3044\u305c\u3044\u3067\u3042\u308b\uff0e\u7279\u306b\u6771\u5317\u539a\u751f\u5c40\u306e\u30d5\u30a1\u30a4\u30eb\u306f\u30d6\u30c3\u30af\u5185\u306b\u8907\u6570\u306e\u30b7\u30fc\u30c8\u304c\u770c\u5225\u306b\u5206\u304b\u308c\u3066\u3044\u308b\u305f\u3081\uff0c\u4e00\u679a\u306e\u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u306b\u30b3\u30d4\u30da\u3059\u308b\u5fc5\u8981\u304c\u3042\u308b\uff0e<\/p>\n

\"\u300c\u30c7\u30fc\u30bf\u306e\u53d6\u5f97\u300d\u300c\u30d5\u30a1\u30a4\u30eb\u304b\u3089\u300d\u300c\u30d5\u30a9\u30eb\u30c0\u30fc\u304b\u3089\u300d\u3068\u9032\u3080\"<\/a>
\u300c\u30c7\u30fc\u30bf\u306e\u53d6\u5f97\u300d\u300c\u30d5\u30a1\u30a4\u30eb\u304b\u3089\u300d\u300c\u30d5\u30a9\u30eb\u30c0\u30fc\u304b\u3089\u300d\u3068\u9032\u3080<\/figcaption><\/figure>\n
\"\u8aad\u307f\u8fbc\u307f\u305f\u3044\u30d5\u30a1\u30a4\u30eb\u306e\u76f4\u4e0a\u306e\u30d5\u30a9\u30eb\u30c0\u30fc\u3092\u6307\u5b9a\u3059\u308b\"<\/a>
\u8aad\u307f\u8fbc\u307f\u305f\u3044\u30d5\u30a1\u30a4\u30eb\u306e\u76f4\u4e0a\u306e\u30d5\u30a9\u30eb\u30c0\u30fc\u3092\u6307\u5b9a\u3059\u308b<\/figcaption><\/figure>\n
\"\u300c\u30c7\u30fc\u30bf\u306e\u5909\u63db\u300d\u3092\u30af\u30ea\u30c3\u30af\u3059\u308b\"<\/a>
\u300c\u30c7\u30fc\u30bf\u306e\u5909\u63db\u300d\u3092\u30af\u30ea\u30c3\u30af\u3059\u308b<\/figcaption><\/figure>\n
\"Content\u5217\u4ee5\u5916\u306f\u524a\u9664\u3059\u308b\"<\/a>
Content\u5217\u4ee5\u5916\u306f\u524a\u9664\u3059\u308b<\/figcaption><\/figure>\n
\"Content\u5217\u306e\u53f3\u80a9\u306e\u30dc\u30bf\u30f3\u3092\u62bc\u4e0b\u3057\u3066\u5c55\u958b\u3059\u308b\"<\/a>
Content\u5217\u306e\u53f3\u80a9\u306e\u30dc\u30bf\u30f3\u3092\u62bc\u4e0b\u3057\u3066\u5c55\u958b\u3059\u308b<\/figcaption><\/figure>\n
\"\u300c\u30d5\u30a1\u30a4\u30eb\u306e\u7d50\u5408\u300d\u3067Sheet1\u3092\u9078\u629e\u3057\u3066OK\"<\/a>
\u300c\u30d5\u30a1\u30a4\u30eb\u306e\u7d50\u5408\u300d\u3067Sheet1\u3092\u9078\u629e\u3057\u3066OK<\/figcaption><\/figure>\n
\"\u3053\u3053\u307e\u3067\u81ea\u52d5\u7684\u306b\u8aad\u307f\u8fbc\u307e\u308c\u308b\"<\/a>
\u3053\u3053\u307e\u3067\u81ea\u52d5\u7684\u306b\u8aad\u307f\u8fbc\u307e\u308c\u308b<\/figcaption><\/figure>\n
\"46469\u884c\u8aad\u307f\u8fbc\u307e\u308c\u305f\"<\/a>
46469\u884c\u8aad\u307f\u8fbc\u307e\u308c\u305f<\/figcaption><\/figure>\n

VBA\u3067\u306e\u51e6\u7406<\/h2>\n

\u3000Power Query\u3067\u51e6\u7406\u3057\u305f\u304b\u3063\u305f\u304c\u8a66\u884c\u932f\u8aa4\u306e\u672b\uff0c\u8ae6\u3081\u305f\uff0e\u3053\u306e\u6642\u70b9\u3067\u5404\u5730\u65b9\u539a\u751f\u5c40\u3054\u3068\uff0c\u533b\u79d1\u3054\u3068\u6b6f\u79d1\u3054\u3068\u306b\u4e00\u3064\u306e\u30d6\u30c3\u30af\u304c\u51fa\u6765\u4e0a\u304c\u3063\u3066\u3044\u308b\u3053\u3068\u3068\u601d\u3046\uff0e\u533b\u79d1\u3092\u307e\u3068\u3081\u308b\u7528\uff0c\u6b6f\u79d1\u3092\u307e\u3068\u3081\u308b\u7528\u306e\u65b0\u898f\u30d6\u30c3\u30af\u3067VBE\u3092\u8d77\u52d5\u3057\u3066\u6a19\u6e96\u30e2\u30b8\u30e5\u30fc\u30eb\u3092\u633f\u5165\u3057\uff0c\u4e0b\u8a18\u30b3\u30fc\u30c9\u3092\u5b9f\u884c\u3059\u308b\uff0eI\u5217\u306b\u3042\u308b\u8a3a\u7642\u79d1\u540d\u3092\u53d6\u5f97\u3059\u308b\u306e\u306b\u82e6\u52b4\u3057\u305f\uff0e<\/p>\n

Option Explicit\n\nSub CollectAllDataRecursive()\n    ' ========================================\n    ' \u5909\u6570\u5ba3\u8a00\n    ' ========================================\n    Dim myFSO       As Object\n    Dim myFolder    As Object\n    Dim myWsDst     As Worksheet\n    Dim myResult()  As Variant\n    Dim j           As Long\n    Dim myPath      As String\n    Dim myMaxRows   As Long\n    Dim myStartTime As Double\n    \n    ' ========================================\n    ' \u521d\u671f\u5316\n    ' ========================================\n    myStartTime = Timer\n    \n    Set myFSO = CreateObject(\"Scripting.FileSystemObject\")\n    \n    ' \u6700\u4e0a\u4f4d\u30d5\u30a9\u30eb\u30c0\u3092\u9078\u629e\n    With Application.FileDialog(msoFileDialogFolderPicker)\n        .Title = \"\u30c7\u30fc\u30bf\u30d5\u30a1\u30a4\u30eb\u304c\u683c\u7d0d\u3055\u308c\u3066\u3044\u308b\u6700\u4e0a\u4f4d\u30d5\u30a9\u30eb\u30c0\u3092\u9078\u629e\"\n        If .Show = -1 Then\n            myPath = .SelectedItems(1)\n        Else\n            Exit Sub\n        End If\n    End With\n    \n    Set myFolder = myFSO.GetFolder(myPath)\n    Set myWsDst = ThisWorkbook.Worksheets(\"Sheet1\")\n    myWsDst.Cells.Clear\n    \n    ' \u7d50\u679c\u683c\u7d0d\u7528\u914d\u5217\u306e\u521d\u671f\u30b5\u30a4\u30ba\n    myMaxRows = 500000\n    ReDim myResult(1 To myMaxRows, 1 To 10)\n    j = 0\n    \n    ' ========================================\n    ' \u30e1\u30a4\u30f3\u51e6\u7406\uff08\u518d\u5e30\u7684\u63a2\u7d22\uff09\n    ' ========================================\n    Application.ScreenUpdating = False\n    Application.DisplayAlerts = False\n    Application.Calculation = xlCalculationManual\n    \n    Debug.Print \"\u30c7\u30fc\u30bf\u53ce\u96c6\u958b\u59cb: \" & Now\n    \n    Call ProcessFolderRecursive(myFSO, myFolder, myResult, j, myMaxRows)\n    \n    Debug.Print \"\u30d5\u30a1\u30a4\u30eb\u51e6\u7406\u5b8c\u4e86: \" & j & \"\u884c\"\n    \n    ' ========================================\n    ' \u7d50\u679c\u306e\u4e00\u62ec\u66f8\u304d\u8fbc\u307f\n    ' ========================================\n    If j > 0 Then\n        Debug.Print \"\u30b7\u30fc\u30c8\u3078\u306e\u66f8\u304d\u8fbc\u307f\u958b\u59cb...\"\n        myWsDst.Range(\"A1\").Resize(j, 10).Value = myResult\n        Debug.Print \"\u66f8\u304d\u8fbc\u307f\u5b8c\u4e86\"\n    End If\n    \n    Application.Calculation = xlCalculationAutomatic\n    Application.ScreenUpdating = True\n    Application.DisplayAlerts = True\n    \n    MsgBox \"\u30c7\u30fc\u30bf\u53ce\u96c6\u304c\u5b8c\u4e86\u3057\u307e\u3057\u305f\u3002\" & vbCrLf & _\n           \"\u7dcf\u884c\u6570: \" & Format(j, \"#,##0\") & \"\u884c\" & vbCrLf & _\n           \"\u51e6\u7406\u6642\u9593: \" & Format(Timer - myStartTime, \"0.0\") & \"\u79d2\", vbInformation\nEnd Sub\n\n\nPrivate Sub ProcessFolderRecursive(ByVal myFSO As Object, _\n                                    ByVal myFolder As Object, _\n                                    ByRef myResult() As Variant, _\n                                    ByRef j As Long, _\n                                    ByRef myMaxRows As Long)\n    Dim myFile      As Object\n    Dim mySubFolder As Object\n    Dim myWB        As Workbook\n    Dim mySh        As Worksheet\n    Dim myRng       As Range\n    Dim myVar       As Variant\n    Dim i           As Long\n    Dim k           As Long\n    \n    ' ========================================\n    ' \u73fe\u5728\u306e\u30d5\u30a9\u30eb\u30c0\u5185\u306e\u30d5\u30a1\u30a4\u30eb\u3092\u51e6\u7406\n    ' ========================================\n    For Each myFile In myFolder.Files\n        With myFile\n            If Right$(.Name, 5) = \".xlsx\" Then\n                \n                Debug.Print \"\u51e6\u7406\u4e2d (\" & j & \"\u884c): \" & .Name\n                \n                On Error Resume Next\n                Set myWB = Workbooks.Open(.Path, ReadOnly:=True, UpdateLinks:=False)\n                On Error GoTo 0\n                \n                If Not myWB Is Nothing Then\n                    On Error Resume Next\n                    Set mySh = myWB.Worksheets(\"Sheet1\")\n                    On Error GoTo 0\n                    \n                    If Not mySh Is Nothing Then\n                        ' A1\u304b\u3089\u306eCurrentRegion\u3092\u53d6\u5f97\n                        Set myRng = mySh.Range(\"A1\").CurrentRegion\n                        \n                        ' A\u5217\uff5eJ\u5217\u306b\u5236\u9650\n                        If myRng.Columns.Count >= 10 Then\n                            Set myRng = Intersect(myRng, mySh.Range(\"A:J\"))\n                        End If\n                        \n                        ' \u30c7\u30fc\u30bf\u304c\u5b58\u5728\u3059\u308b\u304b\u30c1\u30a7\u30c3\u30af\n                        If myRng.Rows.Count > 0 Then\n                            myVar = myRng.Value\n                            \n                            ' 1\u6b21\u5143\u914d\u5217\u306e\u5834\u5408\uff081\u884c\u306e\u307f\uff09\u306e\u5bfe\u5fdc\n                            If IsArray(myVar) Then\n                                If UBound(myVar, 1) = 1 And UBound(myVar, 2) >= 1 Then\n                                    ' 1\u884c\u306e\u307f\u306e\u5834\u5408\n                                    j = j + 1\n                                    \n                                    If j > myMaxRows Then\n                                        myMaxRows = myMaxRows + 100000\n                                        ReDim Preserve myResult(1 To myMaxRows, 1 To 10)\n                                    End If\n                                    \n                                    For k = 1 To UBound(myVar, 2)\n                                        If k <= 10 Then\n                                            myResult(j, k) = myVar(1, k)\n                                        End If\n                                    Next k\n                                Else\n                                    ' \u8907\u6570\u884c\u306e\u5834\u5408\n                                    For i = LBound(myVar, 1) To UBound(myVar, 1)\n                                        j = j + 1\n                                        \n                                        ' \u914d\u5217\u30b5\u30a4\u30ba\u3092\u8d85\u3048\u305f\u3089\u62e1\u5f35\n                                        If j > myMaxRows Then\n                                            myMaxRows = myMaxRows + 100000\n                                            ReDim Preserve myResult(1 To myMaxRows, 1 To 10)\n                                        End If\n                                        \n                                        ' A\u5217\uff5eJ\u5217\u306e\u30c7\u30fc\u30bf\u3092\u30b3\u30d4\u30fc\n                                        For k = LBound(myVar, 2) To UBound(myVar, 2)\n                                            If k <= 10 Then\n                                                myResult(j, k) = myVar(i, k)\n                                            End If\n                                        Next k\n                                    Next i\n                                End If\n                            End If\n                        End If\n                    End If\n                    \n                    myWB.Close SaveChanges:=False\n                    Set myWB = Nothing\n                End If\n            End If\n        End With\n    Next myFile\n    \n    ' ========================================\n    ' \u30b5\u30d6\u30d5\u30a9\u30eb\u30c0\u3092\u518d\u5e30\u7684\u306b\u51e6\u7406\n    ' ========================================\n    For Each mySubFolder In myFolder.SubFolders\n        Call ProcessFolderRecursive(myFSO, mySubFolder, myResult, j, myMaxRows)\n    Next mySubFolder\nEnd Sub<\/pre>\n
\u3000\u533b\u79d1\u4f5c\u696d\u7528\u30d5\u30a1\u30a4\u30eb\uff0c\u6b6f\u79d1\u4f5c\u696d\u7528\u30d5\u30a1\u30a4\u30eb\u3068\u3057\u3066\u305d\u308c\u305e\u308c\u4fdd\u5b58\u3059\u308b\uff0e\u6b21\u306b\u65b0\u898f\u30d6\u30c3\u30af\u3092\u4f5c\u6210\u3057\uff0c\u4e21\u8005\u306e\u30c7\u30fc\u30bf\u3092\u7d71\u5408\u3059\u308b\uff0e\u4e0b\u8a18\u30b3\u30fc\u30c9\u3092\u6a19\u6e96\u30e2\u30b8\u30e5\u30fc\u30eb\u306b\u8a18\u8ff0\u3057\u5b9f\u884c\u3059\u308b\uff0e<\/p>\n
Sub MergeExistingFiles_Safe()\n    ' ========================================\n    ' \u5909\u6570\u5ba3\u8a00\n    ' ========================================\n    Dim myWB1       As Workbook\n    Dim myWB2       As Workbook\n    Dim mySh1       As Worksheet\n    Dim mySh2       As Worksheet\n    Dim myWsDst     As Worksheet\n    Dim myRng1      As Range\n    Dim myRng2      As Range\n    Dim myPath1     As Variant\n    Dim myPath2     As Variant\n    Dim myStartTime As Double\n    Dim myLastRow1  As Long\n    Dim myLastRow2  As Long\n    \n    ' ========================================\n    ' \u521d\u671f\u5316\n    ' ========================================\n    myStartTime = Timer\n    \n    myPath1 = Application.GetOpenFilename(\"Excel Files, *.xls?\", , \"\u533b\u79d1\u30c7\u30fc\u30bf\u30d5\u30a1\u30a4\u30eb\u3092\u9078\u629e\")\n    If myPath1 = False Then Exit Sub\n    \n    myPath2 = Application.GetOpenFilename(\"Excel Files, *.xls?\", , \"\u6b6f\u79d1\u30c7\u30fc\u30bf\u30d5\u30a1\u30a4\u30eb\u3092\u9078\u629e\")\n    If myPath2 = False Then Exit Sub\n    \n    Set myWsDst = ThisWorkbook.Worksheets(\"Sheet1\")\n    myWsDst.Cells.Clear\n    \n    Application.ScreenUpdating = False\n    Application.DisplayAlerts = False\n    Application.Calculation = xlCalculationManual\n    \n    ' ========================================\n    ' 1\u3064\u76ee\u306e\u30d5\u30a1\u30a4\u30eb\u3092\u51e6\u7406\uff08\u533b\u79d1\uff09\n    ' ========================================\n    Debug.Print \"\u533b\u79d1\u30c7\u30fc\u30bf\u8aad\u307f\u8fbc\u307f\u4e2d...\"\n    \n    Set myWB1 = Workbooks.Open(myPath1, ReadOnly:=True, UpdateLinks:=False)\n    Set mySh1 = myWB1.Worksheets(\"Sheet1\")\n    \n    ' \u6700\u7d42\u884c\u3092\u53d6\u5f97\n    myLastRow1 = mySh1.Cells(mySh1.Rows.Count, \"A\").End(xlUp).Row\n    \n    If myLastRow1 > 0 Then\n        ' A\u5217\uff5eJ\u5217\u306e\u5168\u30c7\u30fc\u30bf\u3092\u53d6\u5f97\n        Set myRng1 = mySh1.Range(\"A1:J\" & myLastRow1)\n        \n        Debug.Print \"\u533b\u79d1\u30c7\u30fc\u30bf: \" & Format(myLastRow1, \"#,##0\") & \"\u884c\"\n        Debug.Print \"\u7bc4\u56f2: \" & myRng1.Address\n        \n        ' \u76f4\u63a5\u30b3\u30d4\u30fc\n        myRng1.Copy Destination:=myWsDst.Range(\"A1\")\n    End If\n    \n    myWB1.Close SaveChanges:=False\n    Set myWB1 = Nothing\n    \n    ' ========================================\n    ' 2\u3064\u76ee\u306e\u30d5\u30a1\u30a4\u30eb\u3092\u51e6\u7406\uff08\u6b6f\u79d1\uff09\n    ' ========================================\n    Debug.Print \"\u6b6f\u79d1\u30c7\u30fc\u30bf\u8aad\u307f\u8fbc\u307f\u4e2d...\"\n    \n    Set myWB2 = Workbooks.Open(myPath2, ReadOnly:=True, UpdateLinks:=False)\n    Set mySh2 = myWB2.Worksheets(\"Sheet1\")\n    \n    ' \u6700\u7d42\u884c\u3092\u53d6\u5f97\n    myLastRow2 = mySh2.Cells(mySh2.Rows.Count, \"A\").End(xlUp).Row\n    \n    If myLastRow2 > 0 Then\n        ' A\u5217\uff5eJ\u5217\u306e\u5168\u30c7\u30fc\u30bf\u3092\u53d6\u5f97\n        Set myRng2 = mySh2.Range(\"A1:J\" & myLastRow2)\n        \n        Debug.Print \"\u6b6f\u79d1\u30c7\u30fc\u30bf: \" & Format(myLastRow2, \"#,##0\") & \"\u884c\"\n        Debug.Print \"\u7bc4\u56f2: \" & myRng2.Address\n        \n        ' \u533b\u79d1\u30c7\u30fc\u30bf\u306e\u4e0b\u306b\u8ffd\u52a0\n        myRng2.Copy Destination:=myWsDst.Range(\"A\" & (myLastRow1 + 1))\n    End If\n    \n    myWB2.Close SaveChanges:=False\n    Set myWB2 = Nothing\n    \n    Application.Calculation = xlCalculationAutomatic\n    Application.ScreenUpdating = True\n    Application.DisplayAlerts = True\n    \n    Debug.Print \"\u5b8c\u4e86\"\n    \n    MsgBox \"\u30c7\u30fc\u30bf\u7d71\u5408\u304c\u5b8c\u4e86\u3057\u307e\u3057\u305f\u3002\" & vbCrLf & _\n           \"\u533b\u79d1: \" & Format(myLastRow1, \"#,##0\") & \"\u884c\" & vbCrLf & _\n           \"\u6b6f\u79d1: \" & Format(myLastRow2, \"#,##0\") & \"\u884c\" & vbCrLf & _\n           \"\u5408\u8a08: \" & Format(myLastRow1 + myLastRow2, \"#,##0\") & \"\u884c\" & vbCrLf & _\n           \"\u51e6\u7406\u6642\u9593: \" & Format(Timer - myStartTime, \"0.0\") & \"\u79d2\", vbInformation\nEnd Sub<\/pre>\n
\u3000\u3053\u306e\u6642\u70b9\u3067\u307e\u3060\u7b2c\u4e00\u6b63\u898f\u5f62\u306b\u306f\u306a\u3063\u3066\u304a\u3089\u305a\uff0c\u5358\u306b\u5168\u30c7\u30fc\u30bf\u3092\u4e00\u679a\u306e\u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u306b\u30b3\u30d4\u30da\u3057\u305f\u3060\u3051\u3067\u3042\u308b\uff0e\u3053\u3053\u304b\u3089\u533b\u7642\u6a5f\u95a2\u756a\u53f7\uff0c\u533b\u7642\u6a5f\u95a2\u540d\uff0c\u8a3a\u7642\u79d1\u540d\u306e\u30ea\u30b9\u30c8\uff0c\u90f5\u4fbf\u756a\u53f7\uff0c\u4f4f\u6240\u3092\u53d6\u308a\u51fa\u3059\uff0eA\u5217\u306e\u9023\u756a\u304c\u524d\u306e\u533b\u7642\u6a5f\u95a2\u3068\u6b21\u306e\u533b\u7642\u6a5f\u95a2\u306e\u5883\u754c\u3068\u306a\u3063\u3066\u3044\u308b\uff0eI\u5217\u306b\u8a3a\u7642\u79d1\u540d\u306e\u30ea\u30b9\u30c8\u304c\u3042\u308b\u304c\uff0c\u53d6\u5f97\u3059\u3079\u304d\u3067\u306a\u3044\u6587\u5b57\u5217\u3082I\u5217\u306b\u3042\u308a\uff0c\u305d\u308c\u3089\u3092\u5f3e\u304f\u4ed5\u7d44\u307f\u306e\u69cb\u7bc9\u306b\u82e6\u52b4\u3057\u305f\uff0e\u7d50\u679c\u7684\u306bI\u5217\u306e\u6700\u7d42\u884c\u306b\u3042\u308b\u30bb\u30eb\u304c\u8a3a\u7642\u79d1\u540d\u306e\u30ea\u30b9\u30c8\u3067\u3042\u308b\u3068\u3044\u3046\u69cb\u9020\u3092\u9069\u7528\u3057\u305f\u7d50\u679c\u53d6\u5f97\u306b\u6210\u529f\u3057\u305f\uff0e<\/p>\n
Sub ExtractDepartments_Redesign()\n    ' ========================================\n    ' \u5909\u6570\u5ba3\u8a00\n    ' ========================================\n    Dim myWsSrc     As Worksheet\n    Dim myWsDst     As Worksheet\n    Dim myLastRow   As Long\n    Dim i           As Long\n    Dim myStartRow  As Long\n    Dim myNextStart As Long\n    Dim myOutRow    As Long\n    Dim myCode      As String\n    Dim myName      As String\n    Dim myRawAddr   As String\n    Dim myZip7      As String\n    Dim myAddr      As String\n    Dim myDept      As String\n    \n    ' ========================================\n    ' \u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u30aa\u30d6\u30b8\u30a7\u30af\u30c8\u306e\u53d6\u5f97\n    ' ========================================\n    Set myWsSrc = ThisWorkbook.Sheets(\"Sheet1\")\n    \n    On Error Resume Next\n    Set myWsDst = ThisWorkbook.Sheets(\"Sheet2\")\n    On Error GoTo 0\n    \n    If myWsDst Is Nothing Then\n        Set myWsDst = Worksheets.Add(After:=myWsSrc)\n        myWsDst.Name = \"Sheet2\"\n    Else\n        myWsDst.Cells.Clear\n    End If\n    \n    ' ========================================\n    ' \u30d8\u30c3\u30c0\u30fc\u884c\u306e\u8a2d\u5b9a\n    ' ========================================\n    With myWsDst\n        .Cells(1, 1).Value = \"\u533b\u7642\u6a5f\u95a2\u756a\u53f7\"\n        .Cells(1, 2).Value = \"\u533b\u7642\u6a5f\u95a2\u540d\"\n        .Cells(1, 3).Value = \"\u8a3a\u7642\u79d1\u540d\"\n        .Cells(1, 4).Value = \"M_ZIPCODE\"\n        .Cells(1, 5).Value = \"\u4f4f\u6240\"\n    End With\n    \n    ' ========================================\n    ' \u30e1\u30a4\u30f3\u51e6\u7406\n    ' ========================================\n    myLastRow = myWsSrc.Cells(myWsSrc.Rows.Count, \"A\").End(xlUp).Row\n    myOutRow = 2\n    i = 1\n    \n    Do While i <= myLastRow\n        If IsMedicalStartRow(myWsSrc, i) Then\n            myStartRow = i\n            myNextStart = FindNextStart(myWsSrc, i + 1, myLastRow)\n            \n            If myNextStart = 0 Then\n                myNextStart = myLastRow + 1\n            End If\n            \n            ' \u30c7\u30fc\u30bf\u306e\u53d6\u5f97\n            With myWsSrc\n                myCode = Trim(.Cells(myStartRow, 2).Value & \"\")\n                myName = Trim(.Cells(myStartRow, 3).Value & \"\")\n                myRawAddr = Trim(.Cells(myStartRow, 4).Value & \"\")\n            End With\n            \n            Call ExtractZipAndAddress(myRawAddr, myZip7, myAddr)\n            myDept = FindDeptFromBottom(myWsSrc, myStartRow, myNextStart - 1)\n            \n            ' \u30c7\u30fc\u30bf\u306e\u51fa\u529b\n            With myWsDst\n                .Cells(myOutRow, 1).Value = myCode\n                .Cells(myOutRow, 2).Value = myName\n                .Cells(myOutRow, 3).Value = myDept\n                .Cells(myOutRow, 4).NumberFormat = \"@\"\n                .Cells(myOutRow, 4).Value = myZip7\n                .Cells(myOutRow, 5).Value = myAddr\n            End With\n            \n            myOutRow = myOutRow + 1\n            i = myNextStart\n        Else\n            i = i + 1\n        End If\n    Loop\n    \n    MsgBox \"\u8a3a\u7642\u79d1\uff0b\u90f5\u4fbf\u756a\u53f7\uff0b\u4f4f\u6240\u306e\u62bd\u51fa\u304c\u5b8c\u4e86\u3057\u307e\u3057\u305f\uff08Sheet2\uff09\"\nEnd Sub\n\n\nPrivate Function FindNextStart(ByVal myWs As Worksheet, _\n                                ByVal myStartRow As Long, _\n                                ByVal myLastRow As Long) As Long\n    Dim i As Long\n    \n    For i = myStartRow To myLastRow\n        If IsMedicalStartRow(myWs, i) Then\n            FindNextStart = i\n            Exit Function\n        End If\n    Next i\n    \n    FindNextStart = 0\nEnd Function\n\n\nPrivate Function FindDeptFromBottom(ByVal myWs As Worksheet, _\n                                     ByVal myStartRow As Long, _\n                                     ByVal myEndRow As Long) As String\n    Dim i       As Long\n    Dim myCand  As String\n    \n    For i = myEndRow To myStartRow Step -1\n        myCand = Trim(myWs.Cells(i, 9).Value & \"\")\n        \n        If myCand <> \"\" Then\n            If Not IsNoiseDept2(myCand) Then\n                FindDeptFromBottom = myCand\n                Exit Function\n            End If\n        End If\n    Next i\n    \n    FindDeptFromBottom = \"\"\nEnd Function\n\n\nPrivate Function IsMedicalStartRow(ByVal myWs As Worksheet, _\n                                    ByVal myRow As Long) As Boolean\n    Dim myA As String\n    Dim myC As String\n    \n    myA = myWs.Cells(myRow, 1).Value & \"\"\n    myC = Trim(myWs.Cells(myRow, 3).Value & \"\")\n    \n    If myC = \"\" Then\n        IsMedicalStartRow = False\n        Exit Function\n    End If\n    \n    myA = Replace(myA, \"\u3000\", \" \")\n    myA = Trim(myA)\n    myA = ZenkakuToHankaku(myA)\n    \n    If Left$(myA, 1) = \"(\" Then\n        IsMedicalStartRow = False\n        Exit Function\n    End If\n    \n    If myA <> \"\" And IsNumeric(myA) Then\n        IsMedicalStartRow = True\n    Else\n        IsMedicalStartRow = False\n    End If\nEnd Function\n\n\nPrivate Function IsNoiseDept2(ByVal myTxt As String) As Boolean\n    Dim myT     As String\n    Dim myRest  As String\n    Dim myInner As String\n    Dim myKeys  As Variant\n    Dim myKey   As Variant\n    \n    myT = Trim(Replace(myTxt, \"\u3000\", \" \"))\n    \n    If IsNumeric(myT) Then\n        IsNoiseDept2 = True\n        Exit Function\n    End If\n    \n    If Left$(myT, 1) = \"\uff08\" And Right$(myT, 1) = \"\uff09\" Then\n        myInner = Mid$(myT, 2, Len(myT) - 2)\n        myInner = ZenkakuToHankaku(myInner)\n        \n        If IsNumeric(myInner) Then\n            IsNoiseDept2 = True\n            Exit Function\n        End If\n    End If\n    \n    If myT = \"\u4e00\u822c\" Or myT = \"\u7642\u990a\" Then\n        IsNoiseDept2 = True\n        Exit Function\n    End If\n    \n    If Left$(myT, 2) = \"\u4e00\u822c\" And InStr(myT, \"\uff08\") > 0 Then\n        IsNoiseDept2 = True\n        Exit Function\n    End If\n    \n    myKeys = Array(\"\u4e00\u822c\", \"\u7cbe\u795e\", \"\u611f\u67d3\", \"\u4ecb\u8b77\", \"\u7642\u990a\")\n    For Each myKey In myKeys\n        If Left$(myT, Len(myKey)) = myKey Then\n            myRest = Trim(Mid$(myT, Len(myKey) + 1))\n            myRest = ZenkakuToHankaku(myRest)\n            \n            If myRest <> \"\" And IsNumeric(myRest) Then\n                IsNoiseDept2 = True\n                Exit Function\n            End If\n        End If\n    Next myKey\n    \n    If Left$(myT, 2) = \"\u305d\u306e\u4ed6\" Then\n        IsNoiseDept2 = True\n        Exit Function\n    End If\n    \n    IsNoiseDept2 = False\nEnd Function\n\n\nPrivate Function ZenkakuToHankaku(ByVal myTxt As String) As String\n    Dim i           As Long\n    Dim myCh        As String\n    Dim myCode      As Long\n    Dim myResult    As String\n    \n    myResult = \"\"\n    \n    For i = 1 To Len(myTxt)\n        myCh = Mid$(myTxt, i, 1)\n        myCode = AscW(myCh)\n        \n        If myCode >= &HFF10 And myCode <= &HFF19 Then\n            myResult = myResult & ChrW(myCode - &HFF10 + AscW(\"0\"))\n        Else\n            myResult = myResult & myCh\n        End If\n    Next i\n    \n    ZenkakuToHankaku = myResult\nEnd Function\n\n\nPrivate Sub ExtractZipAndAddress(ByVal myRaw As String, _\n                                  ByRef myZip7 As String, _\n                                  ByRef myAddr As String)\n    Dim myP         As Long\n    Dim i           As Long\n    Dim myCh        As String\n    Dim myZipPart   As String\n    \n    myZip7 = \"\"\n    myAddr = myRaw\n    \n    myP = InStr(myRaw, \"\u3012\")\n    If myP = 0 Then Exit Sub\n    \n    myZipPart = \"\"\n    For i = myP + 1 To Len(myRaw)\n        myCh = Mid$(myRaw, i, 1)\n        \n        If (myCh >= \"0\" And myCh <= \"9\") _\n            Or (AscW(myCh) >= &HFF10 And AscW(myCh) <= &HFF19) _\n            Or myCh = \"-\" _\n            Or myCh = \"\u2010\" _\n            Or myCh = \"\uff0d\" _\n            Or myCh = \"\u2015\" Then\n            myZipPart = myZipPart & myCh\n        Else\n            Exit For\n        End If\n    Next i\n    \n    If myZipPart = \"\" Then Exit Sub\n    \n    myZipPart = ZenkakuToHankaku(myZipPart)\n    myZipPart = Replace(myZipPart, \"\u2010\", \"-\")\n    myZipPart = Replace(myZipPart, \"\uff0d\", \"-\")\n    myZipPart = Replace(myZipPart, \"\u2015\", \"-\")\n    \n    myZip7 = Replace(myZipPart, \"-\", \"\")\n    \n    myAddr = \"\"\n    If i <= Len(myRaw) Then\n        myAddr = Trim(Mid$(myRaw, i))\n    End If\nEnd Sub<\/pre>\n
\u3000\u305d\u306e\u7d50\u679c\u7b2c\u4e00\u6b63\u898f\u5f62\u306e\u624b\u524d\u306e\u72b6\u614b\u3068\u306a\u308b\uff0e\u5168\u89d2\u30b9\u30da\u30fc\u30b9\u304c\u533a\u5207\u308a\u6587\u5b57\u3068\u306a\u3063\u305f\u914d\u5217\u578b\u3068\u307f\u306a\u305b\u306a\u304f\u3082\u306a\u3044\uff0e\u305d\u306e\u4ed6\u306b\u3082\u4e38\u62ec\u5f27\u306e\u4e2d\u304c\u914d\u5217\u578b\u3067\u533a\u5207\u308a\u6587\u5b57\u304c\u5168\u89d2\u30ab\u30f3\u30de\u3068\u306a\u3063\u3066\u3044\u308b\u3082\u306e\uff0c\u5358\u306b\u5168\u89d2\u30ab\u30f3\u30de\u304c\u533a\u5207\u308a\u6587\u5b57\u3068\u306a\u3063\u3066\u3044\u308b\u3082\u306e\u306a\u3069\u304c\u3042\u308b\uff0e\u5168\u89d2\u4e2d\u9ed2\u306f\u533a\u5207\u308a\u6587\u5b57\u3067\u306f\u306a\u304f\uff0c\u304a\u305d\u3089\u304f\u4e00\u4eba\u306e\u533b\u5e2b\u304c\u8907\u6570\u53ef\u3092\u6a19\u699c\u3057\u3066\u3044\u308b\u3082\u306e\u3068\u601d\u308f\u308c\u308b\u305f\u3081\uff0c\u305d\u306e\u307e\u307e\u3068\u3057\u3066\u304a\u304f\uff0e<\/p>\n
\u3000\u4ee5\u4e0a\u306e\u51e6\u7406\u3092\u9806\u6b21\u5b9f\u884c\u3059\u308b\uff0e\u53d6\u308a\u51fa\u3059\u30c7\u30fc\u30bf\u306f\u533b\u7642\u6a5f\u95a2\u756a\u53f7\uff0c\u533b\u7642\u6a5f\u95a2\u540d\uff0c\u8a3a\u7642\u79d1\u540d\uff0c\u90f5\u4fbf\u756a\u53f7\uff0c\u4f4f\u6240\u3067\u3042\u308b\uff0e<\/p>\n
' ========================================\n' \u30c9\u30e9\u30a4\u30d0\u30fc: \u3059\u3079\u3066\u306e\u51e6\u7406\u3092\u9806\u756a\u306b\u5b9f\u884c\n' ========================================\nSub ExecuteAllNormalization()\n    Dim myStartTime As Double\n    Dim myMsg       As String\n    \n    myStartTime = Timer\n    \n    ' \u5b9f\u884c\u78ba\u8a8d\n    myMsg = \"\u4ee5\u4e0b\u306e\u51e6\u7406\u3092\u9806\u756a\u306b\u5b9f\u884c\u3057\u307e\u3059:\" & vbCrLf & vbCrLf & _\n            \"\u2460 \u5168\u89d2\u30b9\u30da\u30fc\u30b9\u3067\u5206\u5272\uff08normalized \u30b7\u30fc\u30c8\uff09\" & vbCrLf & _\n            \"\u2461 \u62ec\u5f27\u5185\u306e\u5c55\u958b\uff08Sheet2\uff09\" & vbCrLf & _\n            \"\u2462 \u8aad\u70b9\u533a\u5207\u308a\u306e\u5c55\u958b\uff08Sheet3\uff09\" & vbCrLf & _\n            \"\u2463 \u4e38\u4ed8\u304d\u6570\u5b57\u3067\u306e\u5c55\u958b\uff08Sheet4\uff09\" & vbCrLf & _\n            \"\u2464 \u30ab\u30f3\u30de\u533a\u5207\u308a\u306e\u5c55\u958b\uff08Sheet5\uff09\" & vbCrLf & vbCrLf & _\n            \"\u5b9f\u884c\u3057\u307e\u3059\u304b\uff1f\"\n    \n    If MsgBox(myMsg, vbYesNo + vbQuestion, \"\u8a3a\u7642\u79d1\u6b63\u898f\u5316\u51e6\u7406\") = vbNo Then\n        Exit Sub\n    End If\n    \n    Application.ScreenUpdating = False\n    Application.DisplayAlerts = False\n    Application.Calculation = xlCalculationManual\n    \n    Debug.Print \"=========================================\"\n    Debug.Print \"\u8a3a\u7642\u79d1\u6b63\u898f\u5316\u51e6\u7406\u958b\u59cb: \" & Now\n    Debug.Print \"=========================================\"\n    \n    ' \u2460 \u5168\u89d2\u30b9\u30da\u30fc\u30b9\u3067\u5206\u5272\n    Debug.Print \"\u2460 \u5168\u89d2\u30b9\u30da\u30fc\u30b9\u3067\u5206\u5272\u51e6\u7406\u4e2d...\"\n    Call NormalizeDepartments\n    Debug.Print \"   \u5b8c\u4e86\"\n    \n    ' \u2461 \u62ec\u5f27\u5185\u306e\u5c55\u958b\n    Debug.Print \"\u2461 \u62ec\u5f27\u5185\u306e\u5c55\u958b\u51e6\u7406\u4e2d...\"\n    Call ExpandDepartments\n    Debug.Print \"   \u5b8c\u4e86\"\n    \n    ' \u2462 \u8aad\u70b9\u533a\u5207\u308a\u306e\u5c55\u958b\n    Debug.Print \"\u2462 \u8aad\u70b9\u533a\u5207\u308a\u306e\u5c55\u958b\u51e6\u7406\u4e2d...\"\n    Call SplitByComma\n    Debug.Print \"   \u5b8c\u4e86\"\n    \n    ' \u2463 \u4e38\u4ed8\u304d\u6570\u5b57\u3067\u306e\u5c55\u958b\n    Debug.Print \"\u2463 \u4e38\u4ed8\u304d\u6570\u5b57\u3067\u306e\u5c55\u958b\u51e6\u7406\u4e2d...\"\n    Call SplitByCircledNumbers\n    Debug.Print \"   \u5b8c\u4e86\"\n    \n    ' \u2464 \u30ab\u30f3\u30de\u533a\u5207\u308a\u306e\u5c55\u958b\n    Debug.Print \"\u2464 \u30ab\u30f3\u30de\u533a\u5207\u308a\u306e\u5c55\u958b\u51e6\u7406\u4e2d...\"\n    Call SplitByCommaOnly\n    Debug.Print \"   \u5b8c\u4e86\"\n    \n    Application.Calculation = xlCalculationAutomatic\n    Application.ScreenUpdating = True\n    Application.DisplayAlerts = True\n    \n    Debug.Print \"=========================================\"\n    Debug.Print \"\u3059\u3079\u3066\u306e\u51e6\u7406\u304c\u5b8c\u4e86\u3057\u307e\u3057\u305f\"\n    Debug.Print \"\u51e6\u7406\u6642\u9593: \" & Format(Timer - myStartTime, \"0.0\") & \"\u79d2\"\n    Debug.Print \"=========================================\"\n    \n    MsgBox \"\u3059\u3079\u3066\u306e\u8a3a\u7642\u79d1\u6b63\u898f\u5316\u51e6\u7406\u304c\u5b8c\u4e86\u3057\u307e\u3057\u305f\u3002\" & vbCrLf & vbCrLf & _\n           \"\u6700\u7d42\u7d50\u679c: Sheet6\" & vbCrLf & _\n           \"\u51e6\u7406\u6642\u9593: \" & Format(Timer - myStartTime, \"0.0\") & \"\u79d2\", _\n           vbInformation, \"\u51e6\u7406\u5b8c\u4e86\"\nEnd Sub\n\n\n' ========================================\n' \u2460 NormalizeDepartments\n' ========================================\nSub NormalizeDepartments()\n    ' ========================================\n    ' \u5909\u6570\u5ba3\u8a00\n    ' ========================================\n    Dim myWsSrc     As Worksheet\n    Dim myWsDst     As Worksheet\n    Dim myLastRow   As Long\n    Dim myOutRow    As Long\n    Dim i           As Long\n    Dim myRaw       As String\n    Dim myParts     As Variant\n    Dim myP         As Variant\n    Dim myNorm      As String\n    \n    ' ========================================\n    ' \u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u30aa\u30d6\u30b8\u30a7\u30af\u30c8\u306e\u53d6\u5f97\n    ' ========================================\n    Set myWsSrc = ThisWorkbook.Sheets(\"Sheet2\")\n    \n    On Error Resume Next\n    Set myWsDst = ThisWorkbook.Sheets(\"normalized\")\n    On Error GoTo 0\n    \n    If myWsDst Is Nothing Then\n        Set myWsDst = Worksheets.Add(After:=myWsSrc)\n        myWsDst.Name = \"normalized\"\n    Else\n        myWsDst.Cells.Clear\n    End If\n    \n    ' ========================================\n    ' \u30d8\u30c3\u30c0\u30fc\u884c\u306e\u8a2d\u5b9a\n    ' ========================================\n    With myWsDst\n        .Cells(1, 1).Value = \"\u533b\u7642\u6a5f\u95a2\u756a\u53f7\"\n        .Cells(1, 2).Value = \"\u533b\u7642\u6a5f\u95a2\u540d\"\n        .Cells(1, 3).Value = \"\u8a3a\u7642\u79d1\"\n        .Cells(1, 4).Value = \"\u90f5\u4fbf\u756a\u53f7\"\n        .Cells(1, 5).Value = \"\u4f4f\u6240\"\n    End With\n    \n    ' ========================================\n    ' \u30e1\u30a4\u30f3\u51e6\u7406\n    ' ========================================\n    myLastRow = myWsSrc.Cells(myWsSrc.Rows.Count, \"A\").End(xlUp).Row\n    myOutRow = 2\n    \n    For i = 2 To myLastRow\n        myRaw = Trim(myWsSrc.Cells(i, 3).Value & \"\")\n        \n        If myRaw <> \"\" Then\n            myParts = Split(myRaw, \"\u3000\")\n            \n            For Each myP In myParts\n                myP = Trim(myP & \"\")\n                \n                If myP <> \"\" Then\n                    myNorm = NormalizeDeptName(myP)\n                    \n                    With myWsDst\n                        .Cells(myOutRow, 1).Value = myWsSrc.Cells(i, 1).Value\n                        .Cells(myOutRow, 2).Value = myWsSrc.Cells(i, 2).Value\n                        .Cells(myOutRow, 3).Value = myNorm\n                        .Cells(myOutRow, 4).Value = myWsSrc.Cells(i, 4).Value\n                        .Cells(myOutRow, 5).Value = myWsSrc.Cells(i, 5).Value\n                    End With\n                    \n                    myOutRow = myOutRow + 1\n                End If\n            Next myP\n        End If\n    Next i\nEnd Sub\n\n\nPrivate Function NormalizeDeptName(ByVal myS As String) As String\n    NormalizeDeptName = Trim(myS)\nEnd Function\n\n\n' ========================================\n' \u2461 ExpandDepartments\n' ========================================\nSub ExpandDepartments()\n    ' ========================================\n    ' \u5909\u6570\u5ba3\u8a00\n    ' ========================================\n    Dim myWsSrc     As Worksheet\n    Dim myWsDst     As Worksheet\n    Dim myLastRow   As Long\n    Dim myOutRow    As Long\n    Dim i           As Long\n    Dim myRaw       As String\n    Dim myExpanded  As Variant\n    Dim myE         As Variant\n    \n    ' ========================================\n    ' \u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u30aa\u30d6\u30b8\u30a7\u30af\u30c8\u306e\u53d6\u5f97\n    ' ========================================\n    Set myWsSrc = ThisWorkbook.Sheets(\"normalized\")\n    \n    On Error Resume Next\n    Set myWsDst = ThisWorkbook.Sheets(\"Sheet3\")\n    On Error GoTo 0\n    \n    If myWsDst Is Nothing Then\n        Set myWsDst = Worksheets.Add(After:=myWsSrc)\n        myWsDst.Name = \"Sheet3\"\n    Else\n        myWsDst.Cells.Clear\n    End If\n    \n    ' ========================================\n    ' \u30d8\u30c3\u30c0\u30fc\u884c\u306e\u8a2d\u5b9a\n    ' ========================================\n    With myWsDst\n        .Cells(1, 1).Value = \"\u533b\u7642\u6a5f\u95a2\u756a\u53f7\"\n        .Cells(1, 2).Value = \"\u533b\u7642\u6a5f\u95a2\u540d\"\n        .Cells(1, 3).Value = \"\u8a3a\u7642\u79d1\"\n        .Cells(1, 4).Value = \"\u90f5\u4fbf\u756a\u53f7\"\n        .Cells(1, 5).Value = \"\u4f4f\u6240\"\n    End With\n    \n    ' ========================================\n    ' \u30e1\u30a4\u30f3\u51e6\u7406\n    ' ========================================\n    myLastRow = myWsSrc.Cells(myWsSrc.Rows.Count, \"A\").End(xlUp).Row\n    myOutRow = 2\n    \n    For i = 2 To myLastRow\n        myRaw = Trim(myWsSrc.Cells(i, 3).Value & \"\")\n        \n        If myRaw <> \"\" Then\n            myExpanded = ExpandDept(myRaw)\n            \n            For Each myE In myExpanded\n                With myWsDst\n                    .Cells(myOutRow, 1).Value = myWsSrc.Cells(i, 1).Value\n                    .Cells(myOutRow, 2).Value = myWsSrc.Cells(i, 2).Value\n                    .Cells(myOutRow, 3).Value = myE\n                    .Cells(myOutRow, 4).Value = myWsSrc.Cells(i, 4).Value\n                    .Cells(myOutRow, 5).Value = myWsSrc.Cells(i, 5).Value\n                End With\n                \n                myOutRow = myOutRow + 1\n            Next myE\n        End If\n    Next i\nEnd Sub\n\n\nPrivate Function ExpandDept(ByVal myS As String) As Variant\n    Dim myResult()  As String\n    Dim myInner     As String\n    Dim myOuter     As String\n    Dim myP1        As Long\n    Dim myP2        As Long\n    Dim myParts     As Variant\n    Dim i           As Long\n    Dim myHasComma  As Boolean\n    \n    myP1 = InStr(myS, \"\uff08\")\n    myP2 = InStr(myS, \"\uff09\")\n    \n    If myP1 = 0 Or myP2 = 0 Or myP2 < myP1 Then\n        myP1 = InStr(myS, \"(\")\n        myP2 = InStr(myS, \")\")\n    End If\n    \n    If myP1 = 0 Or myP2 = 0 Or myP2 < myP1 Then\n        ReDim myResult(0)\n        myResult(0) = myS\n        ExpandDept = myResult\n        Exit Function\n    End If\n    \n    myInner = Mid$(myS, myP1 + 1, myP2 - myP1 - 1)\n    myOuter = Trim(Mid$(myS, myP2 + 1))\n    \n    If myOuter = \"\" Then\n        ReDim myResult(0)\n        myResult(0) = myS\n        ExpandDept = myResult\n        Exit Function\n    End If\n    \n    myHasComma = (InStr(myInner, \"\u3001\") > 0) Or (InStr(myInner, \"\uff0c\") > 0)\n    \n    If myHasComma Then\n        If InStr(myInner, \"\u3001\") > 0 Then\n            myParts = Split(myInner, \"\u3001\")\n        Else\n            myParts = Split(myInner, \"\uff0c\")\n        End If\n        \n        ReDim myResult(UBound(myParts))\n        \n        For i = 0 To UBound(myParts)\n            myResult(i) = Trim(myParts(i)) & myOuter\n        Next i\n    Else\n        ReDim myResult(0)\n        myResult(0) = myS\n    End If\n    \n    ExpandDept = myResult\nEnd Function\n\n\n' ========================================\n' \u2462 SplitByComma\n' ========================================\nSub SplitByComma()\n    ' ========================================\n    ' \u5909\u6570\u5ba3\u8a00\n    ' ========================================\n    Dim myWsSrc     As Worksheet\n    Dim myWsDst     As Worksheet\n    Dim myLastRow   As Long\n    Dim myOutRow    As Long\n    Dim i           As Long\n    Dim myRaw       As String\n    Dim myParts     As Variant\n    Dim myP         As Variant\n    \n    ' ========================================\n    ' \u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u30aa\u30d6\u30b8\u30a7\u30af\u30c8\u306e\u53d6\u5f97\n    ' ========================================\n    Set myWsSrc = ThisWorkbook.Sheets(\"Sheet3\")\n    \n    On Error Resume Next\n    Set myWsDst = ThisWorkbook.Sheets(\"Sheet4\")\n    On Error GoTo 0\n    \n    If myWsDst Is Nothing Then\n        Set myWsDst = Worksheets.Add(After:=myWsSrc)\n        myWsDst.Name = \"Sheet4\"\n    Else\n        myWsDst.Cells.Clear\n    End If\n    \n    ' ========================================\n    ' \u30d8\u30c3\u30c0\u30fc\u884c\u306e\u8a2d\u5b9a\n    ' ========================================\n    With myWsDst\n        .Cells(1, 1).Value = \"\u533b\u7642\u6a5f\u95a2\u756a\u53f7\"\n        .Cells(1, 2).Value = \"\u533b\u7642\u6a5f\u95a2\u540d\"\n        .Cells(1, 3).Value = \"\u8a3a\u7642\u79d1\"\n        .Cells(1, 4).Value = \"\u90f5\u4fbf\u756a\u53f7\"\n        .Cells(1, 5).Value = \"\u4f4f\u6240\"\n    End With\n    \n    ' ========================================\n    ' \u30e1\u30a4\u30f3\u51e6\u7406\n    ' ========================================\n    myLastRow = myWsSrc.Cells(myWsSrc.Rows.Count, \"A\").End(xlUp).Row\n    myOutRow = 2\n    \n    For i = 2 To myLastRow\n        myRaw = Trim(myWsSrc.Cells(i, 3).Value & \"\")\n        \n        If myRaw <> \"\" Then\n            If InStr(myRaw, \"\u3001\") > 0 Then\n                myParts = Split(myRaw, \"\u3001\")\n            Else\n                ReDim myParts(0)\n                myParts(0) = myRaw\n            End If\n            \n            For Each myP In myParts\n                myP = Trim(myP & \"\")\n                \n                If myP <> \"\" Then\n                    With myWsDst\n                        .Cells(myOutRow, 1).Value = myWsSrc.Cells(i, 1).Value\n                        .Cells(myOutRow, 2).Value = myWsSrc.Cells(i, 2).Value\n                        .Cells(myOutRow, 3).Value = myP\n                        .Cells(myOutRow, 4).Value = myWsSrc.Cells(i, 4).Value\n                        .Cells(myOutRow, 5).Value = myWsSrc.Cells(i, 5).Value\n                    End With\n                    \n                    myOutRow = myOutRow + 1\n                End If\n            Next myP\n        End If\n    Next i\nEnd Sub\n\n\n' ========================================\n' \u2463 SplitByCircledNumbers\n' ========================================\nSub SplitByCircledNumbers()\n    ' ========================================\n    ' \u5909\u6570\u5ba3\u8a00\n    ' ========================================\n    Dim myWsSrc     As Worksheet\n    Dim myWsDst     As Worksheet\n    Dim myLastRow   As Long\n    Dim myOutRow    As Long\n    Dim i           As Long\n    Dim myRaw       As String\n    Dim myParts     As Variant\n    Dim myP         As Variant\n    \n    ' ========================================\n    ' \u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u30aa\u30d6\u30b8\u30a7\u30af\u30c8\u306e\u53d6\u5f97\n    ' ========================================\n    Set myWsSrc = ThisWorkbook.Sheets(\"Sheet4\")\n    \n    On Error Resume Next\n    Set myWsDst = ThisWorkbook.Sheets(\"Sheet5\")\n    On Error GoTo 0\n    \n    If myWsDst Is Nothing Then\n        Set myWsDst = Worksheets.Add(After:=myWsSrc)\n        myWsDst.Name = \"Sheet5\"\n    Else\n        myWsDst.Cells.Clear\n    End If\n    \n    ' ========================================\n    ' \u30d8\u30c3\u30c0\u30fc\u884c\u306e\u8a2d\u5b9a\n    ' ========================================\n    With myWsDst\n        .Cells(1, 1).Value = \"\u533b\u7642\u6a5f\u95a2\u756a\u53f7\"\n        .Cells(1, 2).Value = \"\u533b\u7642\u6a5f\u95a2\u540d\"\n        .Cells(1, 3).Value = \"\u8a3a\u7642\u79d1\"\n        .Cells(1, 4).Value = \"\u90f5\u4fbf\u756a\u53f7\"\n        .Cells(1, 5).Value = \"\u4f4f\u6240\"\n    End With\n    \n    ' ========================================\n    ' \u30e1\u30a4\u30f3\u51e6\u7406\n    ' ========================================\n    myLastRow = myWsSrc.Cells(myWsSrc.Rows.Count, \"A\").End(xlUp).Row\n    myOutRow = 2\n    \n    For i = 2 To myLastRow\n        myRaw = Trim(myWsSrc.Cells(i, 3).Value & \"\")\n        \n        If myRaw <> \"\" Then\n            myParts = SplitCircled(myRaw)\n            \n            For Each myP In myParts\n                myP = Trim(myP & \"\")\n                \n                If myP <> \"\" Then\n                    With myWsDst\n                        .Cells(myOutRow, 1).Value = myWsSrc.Cells(i, 1).Value\n                        .Cells(myOutRow, 2).Value = myWsSrc.Cells(i, 2).Value\n                        .Cells(myOutRow, 3).Value = myP\n                        .Cells(myOutRow, 4).Value = myWsSrc.Cells(i, 4).Value\n                        .Cells(myOutRow, 5).Value = myWsSrc.Cells(i, 5).Value\n                    End With\n                    \n                    myOutRow = myOutRow + 1\n                End If\n            Next myP\n        End If\n    Next i\nEnd Sub\n\n\nPrivate Function SplitCircled(ByVal myS As String) As Variant\n    Dim myResult()  As String\n    Dim myBuf       As String\n    Dim i           As Long\n    Dim myCh        As String\n    Dim myCount     As Long\n    \n    ReDim myResult(0)\n    myBuf = \"\"\n    myCount = 0\n    \n    For i = 1 To Len(myS)\n        myCh = Mid$(myS, i, 1)\n        \n        If AscW(myCh) >= &H2460 And AscW(myCh) <= &H2473 Then\n            If Trim(myBuf) <> \"\" Then\n                myResult(myCount) = Trim(myBuf)\n                myCount = myCount + 1\n                ReDim Preserve myResult(myCount)\n            End If\n            \n            myBuf = \"\"\n        Else\n            myBuf = myBuf & myCh\n        End If\n    Next i\n    \n    If Trim(myBuf) <> \"\" Then\n        myResult(myCount) = Trim(myBuf)\n    Else\n        If myCount = 0 Then\n            myResult(0) = myS\n        End If\n    End If\n    \n    SplitCircled = myResult\nEnd Function\n\n\n' ========================================\n' \u2464 SplitByCommaOnly\n' ========================================\nSub SplitByCommaOnly()\n    ' ========================================\n    ' \u5909\u6570\u5ba3\u8a00\n    ' ========================================\n    Dim myWsSrc     As Worksheet\n    Dim myWsDst     As Worksheet\n    Dim myLastRow   As Long\n    Dim myOutRow    As Long\n    Dim i           As Long\n    Dim myRaw       As String\n    Dim myParts     As Variant\n    Dim myP         As Variant\n    \n    ' ========================================\n    ' \u30ef\u30fc\u30af\u30b7\u30fc\u30c8\u30aa\u30d6\u30b8\u30a7\u30af\u30c8\u306e\u53d6\u5f97\n    ' ========================================\n    Set myWsSrc = ThisWorkbook.Sheets(\"Sheet5\")\n    \n    On Error Resume Next\n    Set myWsDst = ThisWorkbook.Sheets(\"Sheet6\")\n    On Error GoTo 0\n    \n    If myWsDst Is Nothing Then\n        Set myWsDst = Worksheets.Add(After:=myWsSrc)\n        myWsDst.Name = \"Sheet6\"\n    Else\n        myWsDst.Cells.Clear\n    End If\n    \n    ' ========================================\n    ' \u30d8\u30c3\u30c0\u30fc\u884c\u306e\u8a2d\u5b9a\n    ' ========================================\n    With myWsDst\n        .Cells(1, 1).Value = \"\u533b\u7642\u6a5f\u95a2\u756a\u53f7\"\n        .Cells(1, 2).Value = \"\u533b\u7642\u6a5f\u95a2\u540d\"\n        .Cells(1, 3).Value = \"\u8a3a\u7642\u79d1\"\n        .Cells(1, 4).Value = \"\u90f5\u4fbf\u756a\u53f7\"\n        .Cells(1, 5).Value = \"\u4f4f\u6240\"\n    End With\n    \n    ' ========================================\n    ' \u30e1\u30a4\u30f3\u51e6\u7406\n    ' ========================================\n    myLastRow = myWsSrc.Cells(myWsSrc.Rows.Count, \"A\").End(xlUp).Row\n    myOutRow = 2\n    \n    For i = 2 To myLastRow\n        myRaw = Trim(myWsSrc.Cells(i, 3).Value & \"\")\n        \n        If myRaw <> \"\" Then\n            myRaw = Replace(myRaw, \"\uff0c\", \"\u3001\")\n            myRaw = Replace(myRaw, \",\", \"\u3001\")\n            \n            If InStr(myRaw, \"\u3001\") > 0 Then\n                myParts = Split(myRaw, \"\u3001\")\n            Else\n                ReDim myParts(0)\n                myParts(0) = myRaw\n            End If\n            \n            For Each myP In myParts\n                myP = Trim(myP & \"\")\n                \n                If myP <> \"\" Then\n                    With myWsDst\n                        .Cells(myOutRow, 1).Value = myWsSrc.Cells(i, 1).Value\n                        .Cells(myOutRow, 2).Value = myWsSrc.Cells(i, 2).Value\n                        .Cells(myOutRow, 3).Value = myP\n                        .Cells(myOutRow, 4).Value = myWsSrc.Cells(i, 4).Value\n                        .Cells(myOutRow, 5).Value = myWsSrc.Cells(i, 5).Value\n                    End With\n                    \n                    myOutRow = myOutRow + 1\n                End If\n            Next myP\n        End If\n    Next i\nEnd Sub<\/pre>\n
\u3000\u4ee5\u4e0a\u306e\u51e6\u7406\u306b\u3088\u308a\u7b2c\u4e00\u6b63\u898f\u5f62\u3068\u306a\u3063\u305f\uff0e<\/p>\n
\u307e\u3068\u3081<\/h2>\n
\u3000\u5168\u56fd\u306e\u5730\u65b9\u539a\u751f\u5c40\u306e\u30b5\u30a4\u30c8\u306b\u3042\u308b\u5404\u533b\u7642\u6a5f\u95a2\u306e\u8a3a\u7642\u79d1\u540d\u3092\u53d6\u5f97\u3057\uff0c\u7b2c\u4e00\u6b63\u898f\u5f62\u306b\u3057\u305f\uff0ePower Query\u3060\u3051\u3067\u306f\u5bfe\u5fdc\u3057\u304d\u308c\u305a\uff0cVBA\u306b\u3088\u308b\u51e6\u7406\u304c\u5fc5\u8981\u3067\u3042\u3063\u305f\uff0e\u6700\u7d42\u7684\u306a\u4ef6\u6570\u306f484,435\u884c\u3067\u3042\u3063\u305f\uff0e\u533b\u7642\u6a5f\u95a2\u6570\u306f156,045\u884c\u3067\u3042\u3063\u305f\uff0e\u30c7\u30fc\u30bf\u306f2026\u5e741\u6708\u6642\u70b9\u306e\u3082\u306e\u3067\u3042\u308b\uff0e<\/p>\n
\u3000\u751f\u6210AI\u3092\u30b3\u30fc\u30c7\u30a3\u30f3\u30b0\u306b\u4f7f\u7528\u3057\u305f\uff0e\u5165\u529b\u3068\u51fa\u529b\u30921\u5bfe1\u3067\u5bfe\u5fdc\u3055\u305b\uff0c1\u30b9\u30c6\u30c3\u30d7\u305a\u3064\u51e6\u7406\u3092\u884c\u308f\u305b\u308b\u3053\u3068\u3067\u76ee\u7684\u3092\u9054\u3057\u305f\uff0e<\/p>\n","protected":false},"excerpt":{"rendered":"
\u3000\u5148\u306e\u8a18\u4e8b\u3067\u306f\u5168\u56fd\u306e\u533b\u7642\u6a5f\u95a2\u306e\u533b\u7642\u6a5f\u95a2\u30b3\u30fc\u30c9\u3092\u53d6\u5f97\u3057\u305f\uff0e\u4eca\u56de\u306f\u5168\u56fd\u306e\u533b\u7642\u6a5f\u95a2\u306e\u8a3a\u7642\u79d1\u3092\u53d6\u5f97\u3057\uff0c\u7b2c\u4e00\u6b63\u898f\u5f62\u306b\u3059\u308b\u3068\u3053\u308d\u307e\u3067\u3092\u89e3\u8aac\u3059\u308b\uff0e \u3000\u4eca\u56de\u304b\u3089\u751f\u6210AI\u3092\u30b3\u30fc\u30c7\u30a3\u30f3\u30b0\u306e\u88dc\u52a9\u3068\u3057\u3066\u4f7f\u7528\u3059\u308b\u3053\u3068\u3092\u304a\u65ad\u308a\u3057\u3066\u304a\u304f\uff0e<\/p>\n","protected":false},"author":1,"featured_media":0,"comment_status":"open","ping_status":"open","sticky":false,"template":"","format":"standard","meta":{"footnotes":""},"categories":[2],"tags":[14004,8036,14003,5460,5815,8384,2474,4773,14005,4634,4067,14006,4530,4772,5809,459,3897,4727,4523,14001,663,4359,13983,13973,13984,14007,31,14002],"class_list":["post-18718","post","type-post","status-publish","format-standard","hentry","category-technology","tag-byval","tag-call","tag-createobjectscripting-filesystemobject","tag-double","tag-for-each","tag-getopenfilename","tag-long","tag-object","tag-on-error-resume-next","tag-option-explicit","tag-power-query","tag-private-function","tag-range","tag-string","tag-variant","tag-vba","tag-vbe","tag-workbook","tag-worksheet","tag-14001","tag-663","tag-4359","tag-13983","tag-13973","tag-13984","tag-ai","tag-31","tag-14002"],"_links":{"self":[{"href":"https:\/\/www.muscle-hypertrophy.com\/index.php?rest_route=\/wp\/v2\/posts\/18718","targetHints":{"allow":["GET"]}}],"collection":[{"href":"https:\/\/www.muscle-hypertrophy.com\/index.php?rest_route=\/wp\/v2\/posts"}],"about":[{"href":"https:\/\/www.muscle-hypertrophy.com\/index.php?rest_route=\/wp\/v2\/types\/post"}],"author":[{"embeddable":true,"href":"https:\/\/www.muscle-hypertrophy.com\/index.php?rest_route=\/wp\/v2\/users\/1"}],"replies":[{"embeddable":true,"href":"https:\/\/www.muscle-hypertrophy.com\/index.php?rest_route=%2Fwp%2Fv2%2Fcomments&post=18718"}],"version-history":[{"count":13,"href":"https:\/\/www.muscle-hypertrophy.com\/index.php?rest_route=\/wp\/v2\/posts\/18718\/revisions"}],"predecessor-version":[{"id":18742,"href":"https:\/\/www.muscle-hypertrophy.com\/index.php?rest_route=\/wp\/v2\/posts\/18718\/revisions\/18742"}],"wp:attachment":[{"href":"https:\/\/www.muscle-hypertrophy.com\/index.php?rest_route=%2Fwp%2Fv2%2Fmedia&parent=18718"}],"wp:term":[{"taxonomy":"category","embeddable":true,"href":"https:\/\/www.muscle-hypertrophy.com\/index.php?rest_route=%2Fwp%2Fv2%2Fcategories&post=18718"},{"taxonomy":"post_tag","embeddable":true,"href":"https:\/\/www.muscle-hypertrophy.com\/index.php?rest_route=%2Fwp%2Fv2%2Ftags&post=18718"}],"curies":[{"name":"wp","href":"https:\/\/api.w.org\/{rel}","templated":true}]}}