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
ChDir "E:\Input"
Workbooks.OpenText Filename:="E:\Input\incentive_A.txt", 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
ActiveWorkbook.SaveAs Filename:="E:\Input\incentive_A.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
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
ActiveWorkbook.SaveAs Filename:=fName, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close False
Next i
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("Excel files(*.xlsx*),*.xlsx*", _
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"
Application.Goto Reference:="R2C1"
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Cut
Windows("LetGetFile.xlsx").Activate
Application.Goto Reference:="R1C1"
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Next i
MsgBox "Finish."
End Sub
Code: Select all
Sub Macro1()
' Macro1 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
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(1)
.Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
nb.Close False
Next i
MsgBox "Finish."
End Sub
ขอบคุณมากครับsnasui wrote: ตัวอย่างการปรับ Code ครับ
Code: Select all
Sub Macro1() ' Macro1 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 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(1) .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues End With Application.CutCopyMode = False nb.Close False Next i MsgBox "Finish." 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
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
If Application.CountIf(.Range("c:c"), VBA.Left(nb.Name, InStrRev(nb.Name, ".") - 1)) Then
Complete แล้วครับsnasui wrote: ปรับบรรทัด If ที่ใช้เช็คชื่อไฟล์เป็นด้านล่างครับ
If Application.CountIf(.Range("c:c"), VBA.Left(nb.Name, InStrRev(nb.Name, ".") - 1)) Then
ขอย้อนกลับมาพัฒนาโค้ดนี้ต่อนะครับ ผมต้องการ นำข้อมูลชีทที่ชื่อไฟล์ ไม่ได้ต่อท้ายด้วย A (คือ B,C,D,E เรียงตามลำดับ) Copy มาวางที่ ไฟล์ที่มีชื่อต่อท้ายด้วย A แล้วให้ทำการ เปลี่ยนชื่อชีทแลพ ชื่อไฟล์ โดยลบ _A ออกไป(รวมถึงชื่อไฟล์ด้วยครับ) แล้วเซพsnasui wrote: ตัวอย่าง Code ครับ
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 ActiveWorkbook.SaveAs Filename:=fName, FileFormat:= _ xlOpenXMLWorkbook, CreateBackup:=False ActiveWorkbook.Close False Next i 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
อ่านแล้วยังไม่กระจ่างครับ เนื่องจากไม่พบไฟล์ที่ไม่มีต่อท้ายด้วยอักขระ A, B ไฟล์ที่ Zip มามี 4 ไฟล์คือ incentive_A.txt, incentive2_A.txt, incentive_ฺB.txt และ incentive2_B.txtparakorn wrote:ต้องการ นำข้อมูลชีทที่ชื่อไฟล์ ไม่ได้ต่อท้ายด้วย A (คือ B,C,D,E เรียงตามลำดับ) Copy มาวางที่ ไฟล์ที่มีชื่อต่อท้ายด้วย A แล้วให้ทำการ เปลี่ยนชื่อชีทแลพ ชื่อไฟล์ โดยลบ _A ออกไป(รวมถึงชื่อไฟล์ด้วยครับ) แล้วเซพ
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