选择要转到错误处理程序的文件夹例程

选择要转到错误处理程序的文件夹例程

关注
发信
关注(28)粉丝(399)

选择要转到错误处理程序的文件夹例程-Excel VBA

本文介绍了选择要转到错误处理程序的文件夹例程-Excel VBA的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

以下是允许用户选择文件夹并在该文件夹中打开文件的代码.本质上是这样做的:

Below is code that allows the user to choose a folder and opens files within the folder. It essentially does this:

  1. 在打开时，根据用户名在工作簿的工作表中查找保存的文件路径.如果不存在，则提示用户找到文件夹，然后将文件路径保存在工作表中

  1. On open, look for filepath saved in worksheet in workbook based on username. If doesn't exist, then prompt user to find folder, then save filepath in worksheet

从步骤1开始，如果根据用户找到了文件路径，请使用该文件路径

From step 1, if filepath is found based on user, use that filepath

我正在经历的是:

  1. 当工作表中没有条目时，它将提示用户找到文件夹，然后继续进行错误处理并询问用户再次找到该文件夹​​

  1. When there's no entries in the sheet, then it will prompt user tofind the folder, but then proceed to the errorhandler and ask theuser to find the folder again

  1. 当工作表中有条目并且文件路径正在运行时，错误处理程序仍处于打开状态，并要求用户查找再次文件夹

如果我取出错误处理程序，一切都会很顺利.只是我想介绍用户移动文件夹的可能性，所以我希望工作簿提示用户找到他们将文件夹移动到的位置，并将工作簿中的现有记录更新为新路径

If I take out the errorhandler, everything is smooth. It's just that I want to cover the possibility of the user moving the folder , so I want the workbook to prompt the user to find where they moved the folder, and update the existing record in the workbook to the new path

我在这里做错了什么?

Private Sub Workbook_Open()


Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Dim vafiles As Variant
Dim filepath As String
Dim filepath2 As String
Dim filepath3 As String
Dim rw As Long
Dim ws As Worksheet
Dim lastrow As Long
Dim icounter As Long

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlManual

Set ws = Worksheets("Paths")
rw = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
Set wkb1 = ThisWorkbook
Set sht1 = wkb1.Sheets("Extract")
'======================================================
'Determine if Path was already saved before. If not, prompt user to choose folder
'======================================================
sal = Application.VLookup(Environ("username"), ws.Range("a:b"), 2, 0)
If IsError(sal) Then

MsgBox ("Please choose where your main folder is located. This will be stored so you won't need to look for it again.")
filepath = PICK_A_FOLDER()
ws.Cells(rw, 2) = PICK_A_FOLDER()
ws.Cells(rw, 1) = Environ("username")

Set wkb2 = Workbooks.Open(filepath & "\ Export.xlsx")
Set sht2 = wkb2.Sheets("Sheet1")
sht2.Cells.Copy Destination:=sht1.Range("a1")
Application.CutCopyMode = False
wkb2.Close True

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Worksheets("Instructions").Activate
Application.Calculation = xlAutomatic

Else

'======================================================
'If filepath exists, use that one
'======================================================
filepath2 = sal

Set wkb2 = Workbooks.Open(filepath2 & "Export.xlsx")


Set sht2 = wkb2.Sheets("Sheet1")
sht2.Cells.Copy Destination:=sht1.Range("a1")
Application.CutCopyMode = False
wkb2.Close True

End If


'======================================================
'If user has moved their folder, we can find it again and update their record
'======================================================
On Error GoTo Errorhandler

Errorhandler:
MsgBox ("Looks like you've moved your Folder. Please find it so your record will be updated")
filepath3 = PICK_A_FOLDER()

lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For icounter = 2 To lastrow
If Cells(icounter, 1) = Environ("username") Then
Cells(icounter, 2) = PICK_A_FOLDER()
End If
Next icounter

Set wkb2 = Workbooks.Open(filepath3 & "")
Set sht2 = wkb2.Sheets("Sheet1")
sht2.Cells.Copy Destination:=sht1.Range("a1")
Application.CutCopyMode = False
wkb2.Close True



Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Worksheets("Instructions").Activate
Application.Calculation = xlAutomatic



End Sub

推荐答案

当SubRoutine执行一项以上任务时，您应考虑将各个任务提取到单独的SubRoutines中.

When a SubRoutine performs more that one task you should consider extracting the individual tasks into separate SubRoutines.

通过这种方式:

  • 您可以独立于其他任务调试每个任务
  • 逻辑被简化为较小的单元
  • 代码更易于阅读
  • 您可以通过将这些子例程放在单独的模块中来减少混乱
  • 可能的代码重用

另一个明显的好处是，通过简化SubRoutine的功能，可以很容易地记住例程模式并在出现类似情况时重用该模式.

Another unapparent benefit is that by simplifying the function of a SubRoutine it is much easier to remember the routines pattern and reuse the pattern when a similar situation arises.

注意:我经常使用 If Len(...)then ，这类似于 If Len(...)>然后为0 .我这样做是为了减少混乱.

Note: I often use If Len(...) then which is analogous to If Len(...) > 0 then. I do this to reduce clutter. 

Function getSharedFolder() As String
    Dim f As Range
    With Worksheets("Paths")
        Set f = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Find(What:=Environ("username"), After:=.Range("A1"), LookAt:=xlWhole)
        If Not f Is Nothing Then
            'Dir([PathName], vbDirectory) returns empty if the [PathName] isn't a folder

            If Len(Dir(f.Offset(0, 1).Value, vbDirectory)) Then
                If Right(f.Offset(0, 1), 1) = "\" Then
                    getSharedFolder = f.Offset(0, 1)
                Else
                    getSharedFolder = f.Offset(0, 1) & "\"
                End If
            End If
        End If
    End With
End Function

Function setSharedFolder() As Boolean
    Dim f As Range
    Dim PathName As String

    PathName = PickSharedFolder
    If Len(PathName) Then

        setSharedFolder = True

        With Worksheets("Paths")
            Set f = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Find(What:=Environ("username"), After:=.Range("A1"), LookAt:=xlWhole)
            If f Is Nothing Then Set f = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Offset(1)

            f.Value = Environ("username")
            f.Offset(0, 1) = PathName

        End With
    End If
End Function

Function PickSharedFolder() As String

    Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Select Folder"

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "Select Main Folder Location"
        If .Show = -1 And .SelectedItems.Count = 1 Then
            PickSharedFolder = .SelectedItems(1)
        Else: Exit Function
        End If
    End With

End Function

Sub ToggleEvents(EnableEvents As Boolean, Optional DisplayAlerts = True)
    With Application
        .DisplayAlerts = DisplayAlerts
        .EnableEvents = EnableEvents
        .ScreenUpdating = EnableEvents
        .Calculation = IIf(EnableEvents, xlCalculationAutomatic, xlCalculationManual)
    End With
End Sub

Sub UpdateWorkBook(FilePath As String)
    Dim WSSource As Worksheet
    With Workbooks.Open(FilePath)

        Set WSSource = .Sheets("Sheet1")

        If WSSource Is Nothing Then
            MsgBox "Sheet1 not found in " & FILENAME, vbCritical, "Update Cancelled"
        Else
            WSSource.Copy Destination:=ThisWorkbook.Sheets("Extract").Range("A1")
        End If
        .Close True
    End With

End Sub

工作簿模块

Private Sub Workbook_Open()
    Const FILENAME As String = "Export.xlsx"
    Const PROMPT As String = "Press [Yes] to continue or [No] to cancel"
    Dim FilePath As String, Title As String, SharedFolder As String

    ToggleEvents False, False

    Do
        SharedFolder = getSharedFolder()

        If Len(SharedFolder) = 0 Then
            Title = "Folder not found"
        Else
            FilePath = SharedFolder & FILENAME
            If Len(Dir(FilePath)) = 0 Then Title = "File not found"
        End If

        If Len(SharedFolder) = 0 Then
            If MsgBox(PROMPT:=PROMPT, Buttons:=vbYesNo, Title:=Title) = vbYes Then
                setSharedFolder
            Else
                Exit Sub
            End If
        End If
    Loop Until Len(Dir(FilePath))

    UpdateWorkBook FilePath

    ToggleEvents True, True

End Sub

这篇关于选择要转到错误处理程序的文件夹例程-Excel VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！

08-30 22:54
Powered by LMLPHP ©2025 选择要转到错误处理程序的文件夹例程 0.039714