Question

我的代码存在问题。我想：

将多个.csv文件合并为一个工作簿，每个.csv文件作为单独的工作表;
缩短工作表名称（因为它们太长而没有额外的元数据;
添加一个新工作表，工作表名称作为工作表的超链接;
将文件另存为xlsx。

我的问题是，当我单步执行代码或通过alt + F8运行它时它工作正常，但是当我使用快捷方式时它除了打开第一个.csv文件之外什么都不做。宏位于personal.xlsb位置。

我相信我可以简化我的代码，所以非常欢迎任何建议。这是我的代码：

Sub CombineCsvFilesWithShortSheetLinks()
    'ctrl+Shift+b
    'Will ask you to open CSV files you wish to combine
Dim myDir As String, fn As String, wb As Workbook
Set wb = ActiveWorkbook
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then myDir = .SelectedItems(1) & "\"
End With

Application.ScreenUpdating = False

If myDir = "" Then Exit Sub
fn = Dir(myDir & "*.csv")
Do While fn <> ""
    With Workbooks.Open(myDir & fn)
        .ActiveSheet.Copy after:=wb.Sheets(wb.Sheets.Count)
        .Close False
    End With
    fn = Dir
Loop
'save as

Dim workbook_Name As Variant
workbook_Name = Application.GetSaveAsFilename
If workbook_Name <> False Then
    ActiveWorkbook.SaveAs _
    Filename:=workbook_Name ', _
    'FileFormat:=52(-4143 xlWorkbookNormal =Excel workbook file format.) 'I had issues with this line because it would just same a extensionless file, so my work around was to just type .xlsx at the end of my file name
End If

'List WS Name Rename Add Hyperlink
'Will shorten the sheet names and add a new sheet with a list of hyperlinks to each sheet
'list old names
Dim xWs As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
xTitleId = "sheetnames"
Application.Sheets(xTitleId).Delete
Sheets("Sheet1").Select
Set xWs = Application.ActiveSheet
xWs.Name = xTitleId
For i = 2 To Application.Sheets.Count
    xWs.Range("A" & (i - 1)) = Application.Sheets(i).Name
Next
Application.DisplayAlerts = True

'list new names'
selectworksheet = "sheetnames"
Range("B1").Select
    ActiveCell.FormulaR1C1 = "=MID(RC[-1],21,12)"
    ActiveCell.Select
    Selection.AutoFill Destination:=ActiveCell.Range("A1:A11")
    ActiveCell.Range("A1:A11").Select
'rename'
selectworksheet = "sheetnames"
For i = 1 To 12
    On Error Resume Next
    oldname = Cells(i, 1).Value
    newname = Cells(i, 2).Value
    Sheets(oldname).Name = newname
Next

'create hyperlink page that Creates Links To All Sheets
Range("C1").Select
Dim cell As Range
For Each xWs In ActiveWorkbook.Worksheets
    If ActiveSheet.Name <> xWs.Name Then
    ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
    "'" & xWs.Name & "'" & "!A1", TextToDisplay:=xWs.Name
    ActiveCell.Offset(1, 0).Select
    End If
Next xWs

'save_workbook
ActiveWorkbook.Save  
End Sub

将csv文件作为具有单独工作表的工作簿进行组合时出现VBA代码问题

0 个答案: