项目汇总

Sub 遍历文件夹(ByVal 指定子文件夹)
    目录路径 = ThisWorkbook.Path & "\"
    获取行列号
    If Not 指定子文件夹 Then
        遍历文件夹路径 = 目录路径
    Else
        遍历文件夹路径 = Cells(ActiveCell.Row, 文件夹名称列号) & "\"
        遍历文件夹路径 = Replace(遍历文件夹路径, ".\", 目录路径)
    End If
    
    Set 已列出文件夹字典 = CreateObject("Scripting.Dictionary")
    For 当前行 = 首行 To 末行
        Cells(当前行, 文件夹名称列号).Select
        已列出文件夹 = ActiveCell
        已列出文件夹 = Replace(已列出文件夹, ".\", 目录路径)
        If "" <> Dir(已列出文件夹, 16) Then
            已列出文件夹字典.Add 已列出文件夹, ""
        Else
            ActiveCell.Interior.ColorIndex = 15
        End If
    Next
    
    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    MyName = Dir(遍历文件夹路径, vbDirectory)    '查找目录
    Do While MyName <> ""
        If MyName <> "." And MyName <> ".." Then
            kk = 32
            On Error Resume Next
            kk = GetAttr(遍历文件夹路径 & MyName)
            If (kk And vbDirectory) = vbDirectory Then    '如果是次级目录
                Dic.Add (遍历文件夹路径 & MyName), MyName   '就往字典中添加这个次级目录名作为一个条目
            End If
        End If
        MyName = Dir    '继续遍历寻找
    Loop
    
    当前行 = 末行 + 1
    
    For Each ke In Dic.keys
        If Not 已列出文件夹字典.Exists(ke) Then '排除已处理
            文件夹短名 = Dic(ke)
            ke = Replace(ke, 目录路径, ".\")
            Cells(当前行, 文件夹名称列号) = ke
            Call 填链接(当前行, 文件夹短名)
            当前行 = 当前行 + 1
        End If
    Next
End Sub
Sub 填链接(ByVal 当前行, ByVal 文件夹短名)
    Dim str As String
    str = "=HYPERLINK(" & Cells(当前行, 文件夹名称列号).Address(False, False)
    str工作表 = str & "&""\" & 文件夹短名 & "=工作表.xlsx"""
    str = str + ",""→"")"
    Cells(当前行, 文件夹名称列号 - 1).Formula = str
'        =HYPERLINK(第一个文件&B34&"."&C34,"←")

    str工作表 = str工作表 + ",""→"")"
    Cells(当前行, 工作表列号).Formula = str工作表

End Sub

Sub 新建项目()
    获取行列号
    模板 = Range("项目文件夹模板")
    
    FilePath = Left(ActiveCell, InStrRev(ActiveCell, "\")) '分解路径
    文件夹短名 = Right(ActiveCell, Len(ActiveCell) - Len(FilePath)) '分解文件名
    
    目录路径 = ThisWorkbook.Path & "\"
    目标 = Cells(ActiveCell.Row, 文件夹名称列号)
    目标 = Replace(目标, ".\", 目录路径)
    
    Set fso = CreateObject("Scripting.FileSystemObject")
'    On Error Resume Next
    fso.CopyFolder 模板, 目标
    Call 填链接(ActiveCell.Row, 文件夹短名)
    
    模板 = 目标 & "\模板=工作表.xlsx"
    目标k = Replace(模板, "模板", 文件夹短名)
    On Error Resume Next
    fso.MoveFile 模板, 目标k
    
    
    模板 = 目标 & "\模板=料单.xls"
    目标k = Replace(模板, "模板", 文件夹短名)
    On Error Resume Next
    fso.MoveFile 模板, 目标k

'    Set kk = GetObject(目标k)
'    With GetObject(目标k)  '使用 GetObject 函数可以访问文件
'        .Range("项目") = 文件夹短名
'        For i = 1 To .Worksheets.Count    '遍历文件的工作表数
'            Debug.Print .Worksheets(i).Name
'        Next
'    End With
    
    Set fso = Nothing
End Sub

Public 禁止改变 As Boolean
Public 表头行 As Integer
Public 首行 As Integer
Public 末行 As Long
'
Public 首列 As Integer
Public 末列 As Integer

Public 编号列号 As Integer
Public 文件夹名称列号 As Integer
Public 工作表列号 As Integer
Public 格式列号 As Integer

Sub 获取行列号()
    首列 = 1
    表头行 = Range("文件夹名称").Row
    首行 = 表头行 + 1
'    Cells.EntireColumn.Hidden = False
    If Cells(首行, 首列) <> "" Then
        末行 = Cells(表头行, 首列).End(xlDown).Row
    Else
        末行 = 表头行
    End If
    末列 = Cells(表头行, 首列).End(xlToRight).Column
    
    文件夹名称列号 = Range("文件夹名称").Column
    工作表列号 = Range("工作表").Column
    
End Sub
Sub 圆整()
    For Each c In Selection.Cells
        原值 = c
        圆整值 = Round(c, 0)
        c.Value = 圆整值
    Next
End Sub
Sub 清除()
    获取行列号
    If 末行 = 表头行 Then Exit Sub
    Cells(首行, 首列).Resize(末行 - 首行 + 1, 末列 - 首列 + 1).Select
    Selection.Interior.Pattern = xlNone
    Selection.ClearContents
    
    Cells(首行, 1).Select
End Sub
Sub cs()
    kk = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    Debug.Print kk
    
    kk = Range("A33").EntireRow.Hidden
    Debug.Print kk
    
    
End Sub


Sub 分割文件(ByVal sw三维文件字典)
    获取行列号
    当前行 = 末行 + 1
    Cells(当前行, 文件路径列号).Select
    For Each k In sw三维文件字典.keys
        kk = Split(k, "|")
        FilePathName = kk(0)
        On Error Resume Next
        配置名 = kk(1)
        Call 拆分文件名(FilePathName)
        
        Cells(当前行, 文件路径列号) = FilePath '填写路径
        Cells(当前行, 文件夹名称列号) = FilenameWHZ '填写文件名
        Cells(当前行, 配置列) = 配置名
        Cells(当前行, 格式列号) = Right(Filename, 6) '填写类型
        
        Cells(当前行, 编号列号) = IIf(sw三维文件字典(k) <> "", sw三维文件字典(k), "0")
        
        当前行 = 当前行 + 1
    Next

End Sub