求一个vba代码大全入门，提取指定路径文件里的指定列，有没有大神？

来源：蜘蛛抓取(WebSpider) 时间：2023-07-21 15:12 标签： VBA代码
这段代码主要是用于获取指定文件夹下的所有文件名，并在Excel工作表中列出文件名、路径、文件扩展名等信息，并添加超链接。有可能出现点击按钮没有反应的情况，可能是以下几种原因：1.没有启用宏请确保在Excel中启用了宏，否则无法执行代码。可以通过打开Excel选项，在“信任中心”下的“信任中心设置”中启用宏。2.文件夹路径不存在或无法访问如果指定的文件夹路径不存在或无法访问，程序会退出，不会执行后续代码。请检查文件夹路径是否正确，以及您是否具有访问该文件夹的权限。3.没有选择文件夹如果您在弹出的文件夹选择对话框中没有选择文件夹，程序也会退出。请确保在弹出的文件夹选择对话框中选择了一个文件夹。4.存在未处理的错误代码中有些可能存在的错误没有进行处理，例如，如果指定文件夹下不存在文件，代码会出现运行时错误。可以添加适当的错误处理程序来处理这些错误，以便更好地提示用户。你可以在代码中添加适当的错误处理程序，并在执行代码时查看控制台中的错误信息，以帮助确定出错的原因。例如:Private Sub CommandButton1_Click()vbnetDim i As IntegerDim path As StringDim ext() As StringDim file As StringOn Error GoTo ErrorHandler '添加错误处理程序If [A2] = "" Then
i = 2Else
i = [A1].End(xlDown).Row + 1End IfWith Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show Then
path = .SelectedItems(1)
Else
Exit Sub
End IfEnd WithIf Right(path, 1) <> "\" Then
path = path & "\"End Iffile = Dir(path)If file = "" Then '判断文件夹下是否存在文件
MsgBox "指定文件夹下没有文件！", vbExclamation, "错误"
Exit SubEnd IfDo Until file = ""
Cells(i, 1).Value = file
Cells(i, 2).Hyperlinks.Add Anchor:=Cells(i, 2), Address:=path & file, TextToDisplay:=file
Cells(i, 3).Hyperlinks.Add Anchor:=Cells(i, 3), Address:=path, TextToDisplay:=path
ext = Split(file, ".")
If UBound(ext) > 0 Then '检查是否有扩展名
Cells(i, 4) = ext(1)
End If
i = i + 1
file = Dir()LoopExit SubErrorHandler: '错误处理程序 MsgBox "运行时错误：" & Err.Description, vbCritical, "错误" Exit SubEnd Sub在代码中添加了错误处理程序和检查文件夹下是否存在文件的代码。如果程序出现运行时错误，会弹出一个消息框提示错误信息，并在控制台中输出错误信息。如果指定的文件夹下没有文件，程序会弹出一个消息框提示错误信息并退出。这样可以更好地提示用户，并避免出现未处理的错误。
本帖最后由 jiamian0128 于 2019-7-25 12:32 编辑在之前的的问题里面，我求助了如何通过EXCEL VBA 提取CAD的数据，非常感谢论坛大神的帮助，现在能满足一些基本要求了，现在把附件代码贴出来。希望论坛大神如果方便能继续指导下小白如何把一些效果完善下，改进下代码。求助1：现在的情况是，读取的CAD文件只能是CAD程序当前打开的文件，能否把读取的CAD文件改为：当前路径名下的_Drawing1.dwg文件。能否运用thispath，currentdocname=“Drawing1”；的之类方式，把要读取的文件限定成当前文件的路径下的Drawing1.dwg文件。求助2：能否把第一行空出来，能够自己填注释进去？然后每次提取的时候，能把上次的都清空，让新提取的值替换进来？现在的效果是比如新提取16行数据，16及16以上的行都会替换，16以下就不会替换。比如新提取出来的如果是13行数据，13及13上以上都是新数据，但是14到16行还是旧数据。求助大神能否帮改下代码，让第一行的数据不会被清空，数据从第二行开始生成，然后每次生成的时候第二行及以下的数据都先清空，然后新数据生成进去。求助3：这个是最最困难的，已知现在能够通过定义CAD图元的组码 arrGroupCode(1) = 0: arrDataValue(1) = "LWPOLYLINE"组值。来筛选出来所有LWPOLYLINE的图元了，然后通过Select Case 属性命令.layer,来提取不同layer(图层)的CAD图元的数据，但是例如.objectname .area.layer这些属性命令局限性太大了，能输出的数据太少。现在在已知CAD图元组值组码的情况下，能否通过定义组码GroupCode和组值DataValue的方式，直接提取某个组码对应的组值？比如现在的效果是通过属性命令.layer的效果是指定该图元的图层，然后A图层的值“A”就输出出来了。能否替换为：已知图层的组码是8，组值是"A",通过定义arrGroupCode(1) = 8时提取其组值arrDataValue(1)=“A”,从而达到arr(i+1,1)=“A”的这个效果。如果可以的话，希望论坛能先指导下我求助1和求助2的代码如何修改。求助3确实实在是比较困难目前。非常感谢。Dim aa = TimerDim acadApp As Object, acadDocs As Object, acadCurrentDoc As ObjectSet acadApp = GetObject(, "AutoCAD.Application")Set acadDocs = acadApp.DocumentsSet acadCurrentDoc = acadDocs.Item(0) '目前假设当前AutoCAD仅打开一个文件 求助：可否把需要读取的CAD对象改为：当前文件路径的“Drawing”文件名的CAD文件Dim acadSSet As ObjectDim arrGroupCode() As Integer, arrDataValue() As VariantDim arr()On Error Resume NextSet acadSSet = acadCurrentDoc.SelectionSets.Item("SS_Temp")acadSSet.DeleteErr.ClearOn Error GoTo 0Set acadSSet = acadCurrentDoc.SelectionSets.Add("SS_Temp")ReDim arrGroupCode(2): ReDim arrDataValue(2)arrGroupCode(0) = -4: arrDataValue(0) = "arrGroupCode(1) = 0: arrDataValue(1) = "LWPOLYLINE"arrGroupCode(2) = -4: arrDataValue(2) = "OR>"acadSSet.Select Mode:=5, FilterType:=arrGroupCode, FilterData:=arrDataValueReDim arr(1 To acadSSet.Count, 1 To 10)For i = 0 To acadSSet.Count - 1With acadSSet.Item(i)Select Case .LayerCase "A"arr(i + 1, 1) = .Layerarr(i + 1, 2) = .Thicknessarr(i + 1, 3) = .area / 1000000Case "B"arr(i + 1, 1) = .Layerarr(i + 1, 2) = .Thicknessarr(i + 1, 3) = .area / 1000000'此处继续求助：能否能把 Select Case 的对象改为筛选到的CAD图元所对应的组码 例如 图层对应的组码是8 我多定义一个arrGroupCode(2) = 8'然后arr(i+1,1) = "这个组码arrGroupCode=8时 的组值 例如 arrDataValue=A 这样的效果"'这样就不用.layer .area 这样属性命令了，毕竟属性命令的局限性太大了，非常感谢大神End SelectEnd WithNextacadSSet.DeleteSet acadSSet = NothingSet acadCurrentDoc = NothingSet acadDocs = NothingSet acadApp = Nothing[a1].Resize(UBound(arr, 1), UBound(arr, 2)) = arrDebug.Print Timer - a'最后一个求助：能否把这个数据产出定义到冲第2行开始生成，因为第一行我想自己标注些注释，然后每次点击都可以先把之前提取的数据清空，替换为新的提取的数据。End Sub1.png(36.16 KB, 下载次数: 0)2019-7-25 12:29 上传求助12.png(53.64 KB, 下载次数: 0)2019-7-25 12:29 上传求助23.png(44.1 KB, 下载次数: 0)2019-7-25 12:30 上传求助32019-7-25 12:30 上传点击文件名下载附件47.64 KB, 下载次数: 16求助

我要回帖

更多关于 VBA代码 的文章

 

随机推荐