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 ImportSheet()
Dim sImportFile As String, sFile As String
Dim sThisBk As Workbook
Dim vfilename As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sThisBk = ActiveWorkbook
sImportFile = Application.GetOpenFilename( _
FileFilter:="All Excel Files, *.xls; *.xlsx;*.xlsm;*.csv", Title:="Open Workbook")
If sImportFile = "False" Then
MsgBox "No File Selected!"
Exit Sub
Else
vfilename = Split(sImportFile, "\")
sFile = vfilename(UBound(vfilename))
Application.Workbooks.Open Filename:=sImportFile
Set wbBk = Workbooks(sFile)
With wbBk
If SheetExists("Raw_Data") Then
Set wsSht = .Sheets("Raw_Data")
wsSht.Copy before:=sThisBk.Sheets("Sheet1")
Else
MsgBox "There is no sheet with name :Raw_Data in:" & vbCr & .Name
End If
wbBk.Close SaveChanges:=False
End With
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Function SheetExists(sWSName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(sWSName)
If Not ws Is Nothing Then SheetExists = True
End Function
ขอบคุณมากค่ะpuriwutpokin wrote:ควรแนบไฟล์ที่จะ import เป็นตัวอย่างด้วยครับ เบื้องต้นลองศึกษาจาก นี้ครับ
http://www.snasui.com/viewtopic.php?f=3 ... ort#p72907
ติดตรงไหนมาถามกันในนี้ต่อครับ
ขอบคุณมากค่ะ .snasui wrote: ศึกษาได้จาก Video ด้านล่างนี้ ลองปรับ Code มาเองก่อน ติดตรงไหนค่อยนำมาถามกันต่อครับ
Code: Select all
Sub collectData()
Dim wb As Workbook, s As Worksheet, db As Worksheet
Dim StrPath As Variant, i As Integer, f As Byte
StrPath = Application.GetOpenFilename(FileFilter:="All Excel Files, *.xls; *.xlsx;*.xlsm;*.csv", _
MultiSelect:=True)
If TypeName(StrPath) = "Boolean" Then Exit Sub
Set db = ThisWorkbook.Sheets(1)
'db.UsedRange.ClearContents
Application.ScreenUpdating = False
For i = 1 To UBound(StrPath)
Set wb = Workbooks.Open(StrPath(1))
For Each s In wb.Worksheets
f = IIf(db.Range("a1").Value = "", 0, 1)
If s.Range("a1").Value <> "" Then
s.UsedRange.Offset(f, 0).Copy
With db
.Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
.PasteSpecial xlPasteValues
End With
End If
Next s
wb.Close False
Application.ScreenUpdating = False
Next i
Application.ScreenUpdating = True
MsgBox "Finished.", vbInformation
End Sub
ขอบคุณมากค่ะpuriwutpokin wrote:ตามโค้ดถ้าไม่ต้องเคลียร์ข้อมูลเก่าก็ลบได้คำสั่งนั้นไดเลยเลยครับ
จากที่ผมเปิดดูไฟล์ที่ Zip มาเป็นไฟล์ข้อมูลเป็น CSV ไฟล์ครับ เหตุผลที่ต้อง Zip เพราะไม่สามารถแนบ CSV ไฟล์ได้ ส่วนไฟล์โปรแกรมที่นำเข้าคือไฟล์นามสกุล .xlsm ครับpuriwutpokin wrote:Zip มาได้ครับ แต่ตัดข้อมูลให้เล็กลงครับ
ตัวอย่าง Code ตามด้านล่าง การจัดการกับ Table จะยุ่งยากกว่าการจัดการกับ Range ปกติ จะมี ListObjects เข้ามาเกี่ยวข้องด้วยครับaapichaya wrote:ถ้าเราต้องการImport ลงตารางเราต้องปรับโค้ดตรงไหนคะ ผลที่ต้องการอยู่ในชีทที่สองค่ะ ECR Approval ซึ่งการอัพโหลดข้อมูล ต้องการอัพโหลดต่อจากแถวสุดท้ายไปเรื่อยๆค่ะ
Code: Select all
Sub collectData()
Dim wb As Workbook, s As Worksheet, db As Worksheet
Dim StrPath As Variant, i As Integer, x As Integer
StrPath = Application.GetOpenFilename(FileFilter:="All Excel Files," _
& "*.xls; *.xlsx;*.xlsm;*.csv(Comma Separated Values);*.txt", _
MultiSelect:=True)
If TypeName(StrPath) = "Boolean" Then Exit Sub
Set db = ThisWorkbook.Sheets(1)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For i = 1 To UBound(StrPath)
Set wb = Workbooks.Open(StrPath(i))
For Each s In wb.Worksheets
s.UsedRange.Offset(1, 0).Resize(s.UsedRange.Rows.Count - 1).Copy
With db
x = .ListObjects("Table4").Range.Rows.Count
If .Range("a" & x).Value <> "" Then x = x + 1
.Range("a" & x).PasteSpecial xlPasteValues
End With
Next s
wb.Close False
Application.ScreenUpdating = False
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub