Snasui Excel Forum

Code: Select all

Sub Macro1()
' Macro1 Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String, wb As Workbook, tb As Workbook
    Dim d As Object, strFile As String, s As Variant
    Dim nb As Workbook
    Set d = CreateObject("Scripting.Dictionary")
    
    Set tb = ThisWorkbook
    strPath = Application.GetOpenFilename("Text files(*.txt*),*.txt*", _
        Title:="Please select text 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), Origin:=874, _
            StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
            Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3 _
            , 1), Array(4, 2), Array(5, 9), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, _
            1), 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, 3), Array(22, 4)), _
            TrailingMinusNumbers:=True
            strFile = Mid(strPath(i), InStrRev(strPath(i), "\") + 1)
            strFile = VBA.Left(strFile, InStrRev(strFile, "_") - 1)
            If Not d.exists(strFile) Then
                d.Add Key:=strFile, Item:=strFile
            End If
    Next i
    On Error GoTo 0
    For Each s In d.keys
        Set nb = Workbooks.Add
        For Each wb In Workbooks
            If InStr(wb.Name, "_") Then
                If VBA.Left(wb.Name, InStrRev(wb.Name, "_") - 1) = 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(1, 0).Copy nb.Sheets(1).Range("a" & _
                            nb.Sheets(1).Rows.Count).End(xlUp).Offset(1, 0)
                    End If
                    wb.Close False
                End If
            End If
        Next wb
        Application.CutCopyMode = False
        nb.Sheets(1).Name = s
        nb.SaveAs Filename:=s, FileFormat:=xlOpenXMLWorkbook
        nb.Close False
    Next s
    MsgBox "Finish."
End Sub

Code: Select all

    For Each wb In Workbooks
        If InStr(tb.Name & "incentive_A.txt" & "incentive2_A.txt" & "incentiveA_A.txt", wb.Name) = 0 Then
        
        
            With Workbooks("incentive_A.txt").Sheets(1)
                wb.Sheets(1).UsedRange.Offset(1, 0).Copy .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0)
            End With
            With Workbooks("incentive2_A.txt").Sheets(1)
                wb.Sheets(1).UsedRange.Offset(1, 0).Copy .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0)
            End With
            With Workbooks("incentiveA_A.txt").Sheets(1)
                wb.Sheets(1).UsedRange.Offset(1, 0).Copy .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0)
            End With
            wb.Close False
        End If
    Next wb

Code: Select all

Sub Macro1()
' Macro1 Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String, wb As Workbook, tb As Workbook
    
    Set tb = ThisWorkbook
    strPath = Application.GetOpenFilename("Text files(*.txt*),*.txt*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    For i = 1 To UBound(strPath)
        fName = VBA.Left(strPath(i), InStr(strPath(i), ".")) & "xlsx"
        Workbooks.OpenText Filename:=strPath(i), Origin:=874, _
            StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
            Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3 _
            , 1), Array(4, 2), Array(5, 9), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, _
            1), 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, 3), Array(22, 4)), _
            TrailingMinusNumbers:=True
    Next i
    For Each wb In Workbooks
        If InStr(tb.Name & "incentive_A.txt" & "incentive_B.txt", wb.Name) = 0 Then
            With Workbooks("incentive_A.txt").Sheets(1)
                wb.Sheets(1).UsedRange.Offset(1, 0).Copy .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0)
            End With
            With Workbooks("incentive_B.txt").Sheets(1)
                wb.Sheets(1).UsedRange.Offset(1, 0).Copy .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0)
            End With
            wb.Close False
        End If
    Next wb
    With Workbooks("incentive_A.txt")
        .Sheets(1).Name = "incentive"
        .SaveAs Filename:=VBA.Left(.Name, InStrRev(.Name, ".") - 1), FileFormat:=xlOpenXMLWorkbook
        .Close False
    End With
    With Workbooks("incentive_B.txt")
        .Sheets(1).Name = "incentive"
        .SaveAs Filename:=VBA.Left(.Name, InStrRev(.Name, ".") - 1), FileFormat:=xlOpenXMLWorkbook
        .Close False
    End With
    
    MsgBox "Finish."
End Sub

Code: Select all

Sub Macro1()
' Macro1 Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String
    
    strPath = Application.GetOpenFilename("Text files(*.txt*),*.txt*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    For i = 1 To UBound(strPath)

        fName = VBA.Left(strPath(i), InStr(strPath(i), ".")) & "xlsx"
        Workbooks.OpenText Filename:=strPath(i), Origin:=874, _
            StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
            Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3 _
            , 1), Array(4, 2), Array(5, 9), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, _
            1), 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, 3), Array(22, 4)), _
            TrailingMinusNumbers:=True
            
        Next i

    Windows("incentive_B.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,1,,COUNTA(C1)-1,COUNTA(R2))"
    Selection.Copy
    Windows("incentive_A.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,COUNTA(C1)+1,,,)"
    ActiveSheet.Paste
        Windows("incentive_C.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,1,,COUNTA(C1)-1,COUNTA(R2))"
    Selection.Copy
    Windows("incentive_A.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,COUNTA(C1)+1,,,)"
    ActiveSheet.Paste
        Windows("incentive_D.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,1,,COUNTA(C1)-1,COUNTA(R2))"
    Selection.Copy
    Windows("incentive_A.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,COUNTA(C1)+1,,,)"
    ActiveSheet.Paste
    Sheets("incentive_A").Name = "incentive"
    
        'ActiveWorkbook.SaveAs Filename:=fName, FileFormat:= _
            'xlOpenXMLWorkbook, CreateBackup:=False
        'ActiveWorkbook.Close False
    
    MsgBox "Finish."
End Sub

Code: Select all

Sub Macro1()
' Macro1 Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String
    
    strPath = Application.GetOpenFilename("Text files(*.txt*),*.txt*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    For i = 1 To UBound(strPath)
        'ChDir "E:\Input"
        fName = VBA.Left(strPath(i), InStr(strPath(i), ".")) & "xlsx"
        Workbooks.OpenText Filename:=strPath(i), Origin:=874, _
            StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
            Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3 _
            , 1), Array(4, 2), Array(5, 9), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, _
            1), 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, 3), Array(22, 4)), _
            TrailingMinusNumbers:=True
    
    Windows("incentive_B.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,1,,COUNTA(C1),COUNTA(R2))"
    Selection.Copy
    Windows("incentive_A.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,COUNTA(C1)+1,,,)"
    ActiveSheet.Paste
    Sheets("incentive_A").Name = "incentive"
    
        'ActiveWorkbook.SaveAs Filename:=fName, FileFormat:= _
            'xlOpenXMLWorkbook, CreateBackup:=False
        'ActiveWorkbook.Close False
    
    Next i
    MsgBox "Finish."
End Sub

Code: Select all

Sub ExportManyfiletoxlsx()
' ExportManyfiletoxlsx Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String
    
    strPath = Application.GetOpenFilename("Text files(*.txt*),*.txt*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    For i = 1 To UBound(strPath)
        fName = VBA.Left(strPath(i), InStr(strPath(i), ".")) & "xlsx"
        Workbooks.OpenText Filename:=strPath(i), Origin:=874, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
        Space:=True, Other:=False, FieldInfo:=Array(Array(1, 2), Array(2, 1)), _
        TrailingMinusNumbers:=True

        ActiveWorkbook.SaveAs Filename:=fName, FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close False
    Next i
    MsgBox "Finish."
End Sub

Sub ImportManyfileToDatabase()
' ImportManyfileToDatabase Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String, nb As Workbook
    Dim tb As Workbook, ans As Integer
    
    Set tb = ThisWorkbook
    strPath = Application.GetOpenFilename("Excel files(*.xlsx*),*.xlsx*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
'    Set C = Column.C: C
'    If Find(tb, C, fName) > 0 Then
'    MsgBox "This File Is Made Are You Continue", vbYesNo
'    If vbYes Then
    For i = 1 To UBound(strPath)
        Set nb = Workbooks.Open(strPath(i))
        With nb.Worksheets(1)
            .Range("a2").Offset(0, .UsedRange.Columns.Count) _
                .Resize(.UsedRange.Rows.Count - 1, 1).Value = .Name
            .UsedRange.Offset(1, 0).Copy
        End With
        With tb.Sheets("Count")
            If Application.CountIf(.Range("c:c"), nb.Name) Then
                ans = MsgBox("This File Is Made Are You Continue.", vbYesNo)
                If ans = vbYes Then
                    .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Else
                .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            End If
        End With
        Application.CutCopyMode = False
        nb.Close False
    Next i
    MsgBox "Finish."

'End If
End Sub

Code: Select all

Sub ImportManyfileToDatabase()
' ImportManyfileToDatabase Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String, nb As Workbook
    Dim tb As Workbook
    
    Set tb = ThisWorkbook
    strPath = Application.GetOpenFilename("Excel files(*.xlsx*),*.xlsx*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    Set C = Column.C: C
    If Find(tb, C, fName) > 0 Then
    MsgBox "This file is already made Are You Continue?", vbYesNo
    If vbYes Then
    For i = 1 To UBound(strPath)
        Set nb = Workbooks.Open(strPath(i))
        With nb.Worksheets(1)
            .Range("a2").Offset(0, .UsedRange.Columns.Count) _
                .Resize(.UsedRange.Rows.Count - 1, 1).Value = .Name
            .UsedRange.Offset(1, 0).Copy
        End With
        With tb.Sheets("Count")
            .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End With
        Application.CutCopyMode = False
        nb.Close False
    Next i
    MsgBox "Finish."

End If
End Sub