Snasui Excel Forum

Code: Select all

Sub AllCountA()

    Dim strPath As Variant, i As Integer
    Dim o As Integer, tb As Workbook, n As Workbook, ns As String
    Dim str As Long, endrow As Long, cendrow As Long, lastrow As Long
    Dim nw As String, nb As Workbook, wb As Workbook, d As Object, s As Variant
    
    Set tb = ThisWorkbook
    
    strPath = Application.GetOpenFilename("CSV files(*.csv*),*.csv*", _
        Title:="Please select Excel files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    On Error Resume Next
    For i = 1 To UBound(strPath)
        fName = VBA.Left(strPath(i), InStr(strPath(i), ".")) & "xlsx"
        Workbooks.OpenText Filename:=strPath(i)
        
        Columns("A:A").Select
        Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 2), Array(10, 2), Array(11, 1), Array(12 _
        , 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), _
        Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array( _
        25, 1)), TrailingMinusNumbers:=True
        
        
            strFile = strPath(i)
            If Not d.exists(strFile) Then
                d.Add Key:=strFile, Item:=strFile
            End If
            
        Next i
        
        On Error GoTo 0
        Set nb = Workbooks.Add
        For Each s In d.keys
        For Each wb In Workbooks
            If wb.Name = s Then
                    If nb.Sheets(1).Range("a1") = "" Then
                        wb.Sheets(1).UsedRange.Copy nb.Sheets(1).Range("a1")
                    Else
                        wb.Sheets(1).UsedRange.Offset(0, 0).Copy nb.Sheets(1).Range("a" & _
                            nb.Sheets(1).Rows.Count).End(xlUp).Offset(1, 0)
                    End If
                End If
        Next wb

        Application.DisplayAlerts = False
        wb.Close False
        Application.DisplayAlerts = True

    Next s
    
    MsgBox "Finish."
    
End Sub

Code: Select all

Sub AllCountA()
    Dim strPath As Variant, i As Integer
    Dim o As Integer, tb As Workbook, n As Workbook, ns As String
    Dim str As Long, endrow As Long, cendrow As Long, lastrow As Long
    Dim nw As String, nb As Workbook, wb As Workbook, d As Object, s As Variant
    
    Set tb = ThisWorkbook
    Set d = CreateObject("Scripting.Dictionary")
    
    strPath = Application.GetOpenFilename("CSV files(*.csv*),*.csv*", _
        Title:="Please select Excel files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    For i = 1 To UBound(strPath)
        fname = VBA.Left(strPath(i), InStr(strPath(i), ".")) & "csv"
        Workbooks.OpenText Filename:=strPath(i)
        
        Columns("A:A").Select
        Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 2), Array(10, 2), Array(11, 1), Array(12 _
        , 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), _
        Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array( _
        25, 1)), TrailingMinusNumbers:=True
        
        strfile = strPath(i)
        If Not d.exists(strfile) Then
            d.Add Key:=strfile, Item:=strfile
        End If
    Next i
    
    Set nb = Workbooks.Add
    For Each s In d.keys
        Debug.Print s
        For Each wb In Workbooks
            If wb.FullName = s Then
                If nb.Sheets(1).Range("a1") = "" Then
                    wb.Sheets(1).UsedRange.Copy nb.Sheets(1).Range("a1")
                Else
                    wb.Sheets(1).UsedRange.Offset(0, 0).Copy nb.Sheets(1).Range("a" & _
                        nb.Sheets(1).Rows.Count).End(xlUp).Offset(1, 0)
                End If
                wb.Close False
            End If
        Next wb
    Next s
    
    MsgBox "Finish."
    
End Sub