ตรวจสอบและปรับปรุงไฟล์ Excel ให้เร็วและเสถียรด้วย File Anatomy Add-in
เครื่องมือนี้ช่วยวิเคราะห์โครงสร้างไฟล์อย่างละเอียด เช่น สูตร, ลิงก์, PivotTable, Styles และ Objects
พร้อมฟังก์ชันล้างสิ่งเกินจำเป็นที่ทำให้ไฟล์ช้า หรือเสียหายได้ในคลิกเดียว
เหมาะสำหรับผู้ใช้ Excel ที่ต้องการควบคุมคุณภาพไฟล์อย่างมืออาชีพ
ทดลองใช้ Add-in
snasui.com ยินดีต้อนรับ 
สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ 
ระบุ Version ของ Excel 
โปรดทราบ สมัครสมาชิก
Login ผ่าน Facebook Reset รหัสผ่าน ติดต่อผู้ดูแลระบบ ตั้งค่าส่วนตัว วิธีการตั้งและตอบกระทู้ จัดรูปแบบตัวอักษร กำหนดขนาดตัวอักษรใน Browser
คำแสดงเจตนา[code] และปิดด้วย [/code] ตัวอย่างเช่น [code]dim r as range[/code] เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)
Code: Select all
Function pull(xref As String) As Variant
'inspired by Bob Phillips and Laurent Longre
'but written by Harlan Grove
'-----------------------------------------------------------------
'Copyright (c) 2003 Harlan Grove.
'
'This code is free software; you can redistribute it and/or modify
'it under the terms of the GNU General Public License as published
'by the Free Software Foundation; either version 2 of the License,
'or (at your option) any later version.
'-----------------------------------------------------------------
Dim xlapp As Object, xlwb As Workbook
Dim b As String, r As Range, c As Range, n As Long
pull = Evaluate(xref)
If CStr(pull) = CStr(CVErr(xlErrRef)) Then
On Error GoTo CleanUp 'immediate clean-up at this point
Set xlapp = CreateObject("Excel.Application")
Set xlwb = xlapp.Workbooks.Add 'needed by .ExecuteExcel4Macro
On Error Resume Next 'now clean-up can wait
n = InStr(InStr(1, xref, "]") + 1, xref, "!")
b = Mid(xref, 1, n)
Set r = xlwb.Sheets(1).Range(Mid(xref, n + 1))
If r Is Nothing Then
pull = xlapp.ExecuteExcel4Macro(xref)
Else
For Each c In r
c.Value = xlapp.ExecuteExcel4Macro(b & c.address(1, 1, xlR1C1))
Next c
pull = r.Value
End If
CleanUp:
If Not xlwb Is Nothing Then xlwb.Close 0
If Not xlapp Is Nothing Then xlapp.Quit
Set xlapp = Nothing
End If
End Function
Arm_anucha wrote: Wed Aug 15, 2018 1:53 pm ส่วนที่ 1
ขอสอบถามหน่อยครับอยากจะดึงข้อมูลที่ตำแหน่งเซลล์ของแต่ละไฟล์โดยที่ไม่ต้องเปิดไฟล์ครับ
ตำแหน่งของ File path จะอยู่ที่คอลัม A , B , C ,D ,E ครับ ของไฟล์ Book2.xlsx
ส่วนข้อมูลจะอยู่ที่ไฟล์ test010 กับ test 011 ครับ
ตอนนี้ใช้สูตรแบบ INDIRECT อยู่แต่สูตรนี้ต้องเปิดไฟล์แล้วก็ copy วางตลอดไม่งันพอปิดไฟล์ที่ดึงข้อมูลมาจะขึ้น #REF! ตลอด
พอจะมีสูตรไหนบ้างครับลองใช้แบบ Index แล้วก็พอทำได้แต่ต้องเปลี่ยนตำแหน่ง กับ ชื่อไฟล์ที่แถบสูตรตลอด
เพราะว่าไฟล์มีจำนวณไม่ตำกว่า 60 ไฟล์ที่ต้องดึงข้อมูลของตำแหน่งเซลล์มาใช้และก็ไม่ได้อยู่ใน Folder เดียวกันครับ
ส่วน Add-in INDIRECT.EXT (MOREFUNC) ที่ลองหามาก็ใช้ไม่เพราะว่าต้องใช้กับ Excel 32bit
งานลักษณะนี้มีทางเลือก 2 ทางเป็นอย่างมากครับ ทางเลือกแรกคือ เปิดไฟล์ต้นทางมา Link ให้เรียบร้อยให้ครบทุกไฟล์ หากมีการเปลี่ยนชื่อไฟล์หรือตำแหน่งไฟล์ให้ใช้การ Edit Link แต่ต้องมั่นใจว่าเป็นการ Link ไปยังเซลล์เดียวกัน ไม่ใช่เดิมอยู่ A1 แล้วพอเปลี่ยนไฟล์เปลี่ยน Folder แล้วจะให้ดึงค่าจาก A2 เช่นนี้จะต้องทำด้วยทางเลือกที่ 2 Arm_anucha wrote: Wed Aug 15, 2018 1:55 pm ส่วนที่ 2
ผมลองได้หาแบบ VBA ดูครับลองใช้ดูก็พอใช้ได้แต่แบบว่าคำนวณได้ช้ามากๆเลยครับ
ถ้ามีการเปลี่ยนแปลงไม่ว่าจะลบแถว ลบ Sheet ใน workbook อันนี้มันจะทำการคำนวณตลอดและก็ช้ามากๆด้วยครับ
พอจะมีวิธีแก้ไข code ให้เร็วขึ้นบ้างไหมครับ
Code นั้นไม่มีทางทำให้เร็วได้เพราะมันจะเปิดไฟล์และปิดไฟล์ทุกเซลล์ที่เขียนสูตรแม้จะเป็นไฟล์เดียวกันก็จะเปิด-ปิดอยู่ตลอดเวลาจนกว่าจะทำงานจนถึงสูตรสุดท้าย หากมีการแก้ไขเซลล์ สูตรจะคำนวณใหม่ทั้งหมดCode: Select all
Sub Test0()
Dim rAll As Range
Dim r As Range, strSource As String
With Sheets("Sheet1")
Set rAll = .Range("g1", .Range("g" & .Rows.Count).End(xlUp))
For Each r In rAll
strSource = "'" & r.Offset(0, -3) & "[" & r.Offset(0, -2) & "]" & _
r.Offset(0, -1) & "'!"
r.Offset(0, 2).Formula = "=" & strSource & r.Value
r.Offset(0, 3).Formula = "=" & strSource & r.Offset(0, 1).Value
Next r
End With
End Sub
Code: Select all
Sub Test0()
Dim rAll As Range
Dim r As Range, strSource As String
With Sheets("Sheet1")
Set rAll = .Range("d2", .Range("d" & .Rows.Count).End(xlUp))
For Each r In rAll
strSource = "'" & r.Offset(0, -3) & "[" & r.Offset(0, -2) & "]" & _
r.Offset(0, -1) & "'!"
r.Offset(0, 2).Formula = "=" & strSource & r.Value
Next r
End With
End Sub
Code: Select all
Sub Test()
Dim MyPath As String
Dim MyFile As String
Dim dirName As String
Dim wks As Worksheet
dirName = "C:\Users\humno\OneDrive\à´Ê¡ì·çÍ»\test\"
MyPath = dirName & "*.xlsx"
MyFile = Dir(MyPath)
If MyFile > "" Then MyFile = dirName & MyFile
Do While MyFile <> ""
If Len(MyFile) = 0 Then Exit Do
Workbooks.Open MyFile
With ActiveWorkbook
For Each wks In .Worksheets
wks.Range("A1").Value = "Toye"
wks.Range("A2").Value = "Boye4"
Next
End With
ActiveWorkbook.Close SaveChanges:=True
MyFile = Dir
If MyFile > "" Then MyFile = dirName & MyFile
Loop
End Sub
Arm_anucha wrote: Tue Aug 21, 2018 6:28 pm เปลี่ยนค่าใดๆ ใน Cell ของไฟล์ test010.xlsx โดยใช้ตำแหน่ง File path ที่อยู่ในไฟล์ change.xlsm
Code: Select all
Sub Test0()
Dim rAll As Range
Dim r As Range, strSource As String
With Sheets("Sheet1")
Set rAll = .Range("d2", .Range("d" & .Rows.Count).End(xlUp))
For Each r In rAll
strSource = r.Offset(0, -3) & r.Offset(0, -2)
Workbooks.Open Filename:=(strSource)
ActiveSheet.Range("A1").Value = Sheet1.Range("F2")
ActiveWorkbook.Save
ActiveWorkbook.Close
Next r
End With
End SubstrSourceคืออะไร จะกำหนดค่าอะไรให้กับตัวแปรนี้หรือนำค่าจากไหนมากำหนดให้ตัวแปรนี้ครับ ตัวอย่าง Code ครับCode: Select all
Dim rAll As Range, tgBook As Workbook
Dim r As Range, strSource As String
Dim d As Object, x() As Variant, i As Integer
Set d = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
Set rAll = .Range("b2", .Range("b" & .Rows.Count).End(xlUp))
For Each r In rAll
strSource = r.Offset(0, -1).Value & r.Value
If Not d.Exists(strSource) Then
d.Add Key:=strSource, Item:=strSource
End If
Next r
x = d.keys
For i = 0 To UBound(x)
Set tgBook = Workbooks.Open(Filename:=x(i))
For Each r In rAll
If tgBook.Name = r.Value Then
With tgBook.Worksheets(r.Offset(0, 1).Value)
.Range(r.Offset(0, 2).Value) = r.Offset(0, 4).Value
.Range(r.Offset(0, 3).Value) = r.Offset(0, 5).Value
End With
End If
Next r
tgBook.Save
tgBook.Close
Next i
End With