EXCEL TOOLS
Excel Add-ins ที่พัฒนาโดยคุณสันติพงศ์ ณสุย (MVP Excel 2010-2020) ด้วยภาษา C# เพื่อแก้ไขปัญหาไฟล์ใหญ่ คำนวณนาน ทำงานช้า จัดการข้อมูลต่าง ๆ ที่ทำงานประจำวันได้อย่างสะดวกรวดเร็ว สนใจคลิกไปดูได้ที่นี่ครับ => Excel Tools
Excel Add-ins ที่พัฒนาโดยคุณสันติพงศ์ ณสุย (MVP Excel 2010-2020) ด้วยภาษา C# เพื่อแก้ไขปัญหาไฟล์ใหญ่ คำนวณนาน ทำงานช้า จัดการข้อมูลต่าง ๆ ที่ทำงานประจำวันได้อย่างสะดวกรวดเร็ว สนใจคลิกไปดูได้ที่นี่ครับ => Excel Tools
[code]
และปิดด้วย [/code]
ตัวอย่างเช่น [code]dim r as range[/code]
เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)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
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
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