Question

所以这里是3部分宏的一部分，它允许您浏览到一个文件夹并合并/转置/保留一堆.csv文件的标题。我们遇到的问题是在哪里注入一些代码，以便将路由和帐号格式化为文本并保留其前导零。如果最简单的解决方案是将整个工作表格式化为文本，那么这对我们很有用......无论如何都不需要详细说明，因为这些信息不会总是在同一列中。

提前致谢！

Option Explicit

'Set a public constant variable
Public Const DNL As String = vbNewLine & vbNewLine

Sub ImportData()

'Declare all variables
Dim wb As Workbook, ws As Worksheet
Dim wbX As Workbook, wsX As Worksheet
Dim i As Long, iRow As Long, iFileNum As Long, sMsg As String
Dim vFolder As Variant, sSubFolder As String, sFileName As String
Dim bOpen As Boolean

'Turn off some application-level events to improve code efficiency
Call TOGGLEEVENTS(False)

'Have the user choose the folder
vFolder = BrowseForFolder()

'Exit if nothing was chosen, variable will be False
If vFolder = False Then Exit Sub

'Check if this is what the user wants to do, confirm with a message box, exit if no
sMsg = "Are you sure you want to import data from this folder:"
sMsg = sMsg & DNL & vFolder
If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "ARE YOU SURE?") <> vbYes Then Exit Sub

'Set sub-folder as variable for save name at end of routine
sSubFolder = Right(vFolder, Len(vFolder) - InStrRev(vFolder, Application.PathSeparator))

'Set destination file with one worksheet
Set wb = Workbooks.Add(xlWBATWorksheet)
Set ws = wb.Sheets(1)

'This will be the row to start data on, to incriment in loop
iRow = 2

'Loop through files in folder
sFileName = Dir$(vFolder & "\")
Do Until sFileName = ""

    'Check that the file pattern matches what you want, i.e. 12.16.00.xls
    If sFileName Like "*.csv" Then '### set file extension here

        'Check to see if the file is open
        'If file is open, set as variable, if not, open and set as variable
        If ISWBOPEN(sFileName) = True Then
            Set wbX = Workbooks(sFileName)
            bOpen = True
        Else
            Set wbX = Workbooks.Open(vFolder & "\" & sFileName)
            bOpen = False
        End If

        'Set first sheet in target workbok as worksheet variable, from which to mine data
        Set wsX = wbX.Sheets(1)

        'Get last row from column A (range for copy/pasting)
        i = wsX.Cells(wsX.Rows.Count, 1).End(xlUp).Row

        'Check if a file has been added, if not add headers (frequency)
        If iFileNum = 0 Then
            ws.Range("B1", ws.Cells(1, i + 1)).Value = Application.Transpose(wsX.Range("A1:A" & i))
        End If

        'Add data
        ws.Range("B" & iRow, ws.Cells(iRow, i + 1)).Value = Application.Transpose(wsX.Range("B1:B" & i))

        'Add file name to column A
        ws.Range("A" & iRow).Value = "'" & Left$(sFileName, Len(sFileName) - 4)

        'Incriment variable values
        iRow = iRow + 1
        iFileNum = iFileNum + 1

        'If file was closed to start with, clean up and close it
        If bOpen = False Then wbX.Close SaveChanges:=False

    End If

    'Get next file name
    sFileName = Dir$()
Loop

'Check if file name to save exists
If Dir$(vFolder & "\" & sSubFolder & ".xls", vbNormal) = "" Then
    wb.SaveAs vFolder & "\" & sSubFolder & ".xls"
    MsgBox "Complete!", vbOKOnly
Else
    MsgBox "File already exists!  File is NOT saved!", vbInformation, "COMPLETE!"
End If

'Reset events back to application defaults
Call TOGGLEEVENTS(True)

End Sub

注入代码以将所有列格式化为文本以保留CSV中的前导零

0 个答案: