请帮忙修改一下VBA代码（建立目录）

pzzzxh · 发表于 2024-1-5 10:48

以下的VBA代码是在excel文件中创建一个文件夹的目录，本人在运行过程中出现是一直在循环建立目录的情况，请大侠帮忙修订一下代码！
Private Sub CheckBox1_Click()
If Sheet2.CheckBox1.Value = True Then
Call update
End If
End Sub
Private Sub CommandButton1_Click()
Call add
End Sub

Private Sub CommandButton2_Click() '折叠文件夹
Dim total_rows#
total_rows = Sheet3.Cells(1, 4).Value
Application.ScreenUpdating = False
For temrows = 2 To total_rows
If Range("j" & temrows).Interior.ColorIndex = -4142 Then
ActiveSheet.Range("j" & temrows).EntireRow.Hidden = True
End If
Next
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton3_Click() '展开文件夹
展开文件夹
End Sub
Private Function 展开文件夹()
ActiveSheet.usedrange.Select
Selection.EntireRow.Hidden = False

[a1].Select
End Function

Private Sub CommandButton4_Click()
Sheet3.Range(Sheet3.Cells(1, 2), Sheet3.Cells(Sheet3.Range("B65536").End(xlUp).Row, 2)).clear
Call clear
End Sub
Private Sub CommandButton5_Click() '更新目录
Dim p#, TEMP#
Call clear
i = 2
tmp_rows = 2
TEMP = Sheet3.Range("b65536").End(xlUp).Row
For p = 1 To TEMP
      'tmp_rows = Sheet3.Range("D1").Value

      spath = Sheet3.Cells(p, 2)
      spath_tmp = spath
      If spath = "" Then Exit Sub
      Call 展开文件夹
      Call 获得当前文件夹名
      spath = spath & "\"
      Call 获取当前文件名
      Call getfolder(spath)
      Sheet3.Range("D1") = i
Next
         Call 设置目录线
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
End Sub
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'End Sub
Sub tt()
MsgBox Range("b:b").End(xlUp).Row
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column < 11 Then
Cancel = True
On Error Resume Next    '如出错,则从出错行下一行开始执行
Dim Myra As Range
Dim Myur As Integer, Tem1 As Integer, Temr As Integer, Temc As Integer
Myur = Sheet3.Cells(1, 4).Value '获得使用单元格的行数
If Target.Row <= 1 Then Exit Sub '选定单元格的行号<=3时退出
If Target.Interior.ColorIndex <> -4142 Then '选定单元格内填充颜色为3_兰
   Set Myra = Target.Cells(1, 1).MergeArea.Cells(1, Target.Count) '返回选定合并单元内最右边的单元格
   If Myra.MergeCells Then '判断其是否为合并单元格
      Temr = Myra.Row '获得行号
      Temc = Myra.Column '获得列号
      For Tem1 = Temr + 1 To Myur
         If Cells(Tem1, Temc).MergeCells Then '判断其是否为合并单元格
            If Tem1 - 1 < Temr + 1 Then Exit Sub
            Range(Cells(Temr + 1, Temc), Cells(Tem1 - 1, Temc)).EntireRow.Hidden = _
               Not Range(Cells(Temr + 1, Temc), Cells(Tem1 - 1, Temc)).EntireRow.Hidden
               '隐藏或显示行
            Exit Sub
         End If
      Next
      Range(Cells(Temr + 1, Temc), Cells(Myur, Temc)).EntireRow.Hidden = _
         Not Range(Cells(Temr + 1, Temc), Cells(Myur, Temc)).EntireRow.Hidden
         '隐藏或显示行
      End If
End If
End If
End Sub

JackLei · 发表于 2024-1-5 11:19

试试这两款
通过百度网盘分享的文件：文件目录自动生成…等2个文件
链接:https://pan.baidu.com/s/1rXab9ZXfSn72oJjoWnk28Q?pwd=4gcu 
提取码:4gcu
复制这段内容打开「百度网盘APP 即可获取」

pzzzxh · 发表于 2024-1-5 11:32

JackLei 发表于 2024-1-5 11:19
试试这两款
通过百度网盘分享的文件：文件目录自动生成…等2个文件
链接:https://pan.baidu.com/s/1rXab9 ...

我整个代码就是文件目录自动生成（含文件链接）里面提取出来的！

pzzzxh · 发表于 2024-1-8 23:28

pzzzxh 发表于 2024-1-5 11:32
我整个代码就是文件目录自动生成（含文件链接）里面提取出来的！

链接：https://pan.baidu.com/s/1UmbiGJBLlLnQw2M_a1FLqg?pwd=1B3C
提取码：1B3C
原始的文件在该链接，是一个excel文件，请大侠出手！
存在的问题是文件多了以后一直重复建立一个文件的目录！

silartsua · 发表于 2024-1-9 03:11

Option Explicit

Dim i As Long

Private Sub CheckBox1_Click()
    If Sheet2.CheckBox1.Value = True Then
        Call update
    End If
End Sub

Private Sub CommandButton1_Click()
    Call add
End Sub

Private Sub CommandButton2_Click() '折叠文件夹
    Dim total_rows As Long
    total_rows = Sheet3.Cells(1, 4).Value
    Application.ScreenUpdating = False
    For temrows = 2 To total_rows
        If Sheet3.Range("j" & temrows).Interior.ColorIndex = -4142 Then
            Sheet3.Rows(temrows).Hidden = True
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Private Sub CommandButton3_Click() '展开文件夹
    展开文件夹
End Sub

Private Function 展开文件夹()
    ActiveSheet.UsedRange.Select
    Selection.EntireRow.Hidden = False
    Sheet3.Range("a1").Select
End Function

Private Sub CommandButton4_Click()
    Sheet3.Range(Sheet3.Cells(1, 2), Sheet3.Cells(Sheet3.Range("B65536").End(xlUp).Row, 2)).Clear
    Call clear
End Sub

Private Sub CommandButton5_Click() '更新目录
    Call clear
    i = 2
    Dim p As Long, TEMP As Long
    TEMP = Sheet3.Range("b65536").End(xlUp).Row
    For p = 1 To TEMP
        spath = Sheet3.Cells(p, 2)
        If spath = "" Then Exit Sub
        Call 展开文件夹
        Call 获得当前文件夹名
        spath = spath & "\"
        Call 获取当前文件名
        Call getfolder(spath)
        Sheet3.Range("D1") = i
    Next
    Call 设置目录线
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Column < 11 Then
        Cancel = True
        On Error Resume Next
        Dim Myra As Range
        Dim Myur As Long, Tem1 As Long, Temr As Long, Temc As Long
        Myur = Sheet3.Cells(1, 4).Value
        If Target.Row <= 1 Then Exit Sub
        If Target.Interior.ColorIndex <> -4142 Then
            Set Myra = Target.Cells(1, 1).MergeArea.Cells(1, Target.Count)
            If Myra.MergeCells Then
                Temr = Myra.Row
                Temc = Myra.Column
                For Tem1 = Temr + 1 To Myur
                    If Cells(Tem1, Temc).MergeCells Then
                        If Tem1 - 1 < Temr + 1 Then Exit Sub
                        Range(Cells(Temr + 1, Temc), Cells(Tem1 - 1, Temc)).EntireRow.Hidden = _
                           Not Range(Cells(Temr + 1, Temc), Cells(Tem1 - 1, Temc)).EntireRow.Hidden
                        Exit Sub
                    End If
                Next
                Range(Cells(Temr + 1, Temc), Cells(Myur, Temc)).EntireRow.Hidden = _
                   Not Range(Cells(Temr + 1, Temc), Cells(Myur, Temc)).EntireRow.Hidden
            End If
        End If
    End If
End Sub

添加 Option Explicit，以确保变量声明。
修正循环中的一些错误，例如 temrows 没有声明，修改为 Dim temrows As Long。
将 ActiveSheet 替换为具体的工作表，例如 Sheet3，以确保在正确的工作表上执行操作。
修正隐藏行的代码，使用 Sheet3.Rows(temrows).Hidden = True 替代 ActiveSheet.Range("j" & temrows).EntireRow.Hidden = True。
在 CommandButton5_Click 中的 Call clear 之后添加 i = 2，以确保每次更新目录时重新从第二行开始。

pzzzxh · 发表于 2024-1-9 22:35

silartsua 发表于 2024-1-9 03:11
[md]```vba
Option Explicit

链接：https://pan.baidu.com/s/1XA2xSDEy1lL830NOcYzprQ?pwd=1B3C
提取码：1B3C
这里面是原始的文件，开发工具，查看代码即可看到，存在的问题在图片里面，就是重复建立某一个文件夹！一般情况下均没问题，但在使用过程中出现了重复建立文件目录的情况，本人不是搞程序的还请帮忙，！

martn · 发表于 2024-1-16 08:39

看看先，路过瞧瞧学习le !

帐号		自动登录	找回密码
密码			注册[Register]

[其他求助] 请帮忙修改一下VBA代码（建立目录）

个人中心