ตรวจสอบและปรับปรุงไฟล์ 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] เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)
Stock Take Test.xls
บุคคลที่ได้ชื่อเป็นอาจารยื ท่านใช้ชื่อว่า "คนควน" น่ะครับ ขอบคุณครับคุณ Bank9597 เจอกันอีกแล้วน่ะครับ งั้นผมขอถามว่าผมต้องเพิ่มหรือปก้ไขส่วนไหนบ้างครับ
ถ้างดเว้นการอ้างถึงได้ก็จะดีครับ อย่าพยายามอ้างถึงเพื่อความน่าเชื่อถือของข้อมูลครับ เพราะมีโอกาสที่ผมจะถูกหมั่นไส้ได้โดยง่ายbank9597 wrote:ที่ผมอ้างชื่ออาจารย์บ่อยๆในเว็บอื่น นั่นก็คือ "คนควน" นั่นเองครับ
สำหรับการเขียน Code ถ้ายังไม่แม่นก็ควรจะค่อย ๆ เรียนรู้ไปครับ Code ตาม Link นั้นไม่ง่ายนัก เพราะใช้ Array เข้ามาประกอบอยู่ด้วย การทำเช่นตัวอย่างไฟล์ที่แนบมาไม่จำเป็นต้องใช้ VBA ครับsnoopy1150 wrote:เรียน อาจารย์ ครับ
จาก http://snasui.blogspot.com/2011/06/vba_26.html
ที่ อาจารย์เคยได้เขียนไว้ ผมลองนำมาแก้บางจุด vba สามารถรันได้ แต่ข้อมูลไม่ show ครับ
จึงรบกวน อาจารย์ ตรวจสอบที่ครับ
Code: Select all
Option Explicit
Option Base 1
Sub ShowEmp()
Dim a() As Variant, lng As Long
Dim r As Range, rAll As Range
Dim rt As Range, rl As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
rl = Rows.Count
With Worksheets("2703")
Set rAll = .Range("F2", .Range("F" & rl).End(xlUp))
End With
For Each r In rAll
If r = Worksheets("From").Range("A2") Then
lng = lng + 1
ReDim Preserve a(5, lng)
a(1, lng) = lng
a(2, lng) = r.Offset(0, -5)
a(3, lng) = r.Offset(0, -4)
a(4, lng) = r.Offset(0, -3)
a(5, lng) = r.Offset(0, -2)
End If
Next r
If lng > 0 Then
With Worksheets("From")
Set rt = .Range("B4", .Range("F" & lng - 1 + 4))
If .Range("B4") <> "" Then
.Range("B4", .Range("B" & rl).End(xlUp).Offset(0, 4)).ClearContents
End If
.Range("B4:F4").Copy
rt.PasteSpecial xlPasteFormats
rt = Application.Transpose(a)
.Range(.Range("B3").End(xlDown).Offset(1, 0), .Range("F" & rl)).ClearContents
End With
Else
MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
โอ๊ว....ไม่ต้องห่วงครับ ทุกอย่างอยู่ในขอบเขตที่เคยกล่าวไว้แล้วครับ 
ช่วยระบุตำแหน่งที่บอกว่าไม่ตรงครับ ค่าที่ถูกควรเป็นค่าใด กรณีเป็น Error ช่วยจับภาพ Error นั้นมาแสดงด้วยครับ ลองตามนี้ครับ ว่าใช่หรือไม่
Code: Select all
Option Explicit
Option Base 1
Sub ShowEmp()
Dim a() As Variant, lng As Long
Dim r As Range, rAll As Range
Dim rt As Range, rl As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
rl = Rows.Count
With Worksheets("2703")
Set rAll = .Range("F2", .Range("F" & rl).End(xlUp))
End With
For Each r In rAll
If r = Worksheets("From").Range("A2") Then
lng = lng + 1
ReDim Preserve a(5, lng)
a(1, lng) = lng
a(2, lng) = r.Offset(0, -4)
a(3, lng) = r.Offset(0, -3)
a(4, lng) = r.Offset(0, -2) And r.Offset(0, -1)
a(5, lng) = r.Offset(0, 0)
End If
Next r
If lng > 0 Then
With Worksheets("From")
Set rt = .Range("B4", .Range("F" & lng - 1 + 4))
If .Range("B4") <> "" Then
.Range("B4", .Range("B" & rl).End(xlUp).Offset(0, 4)).ClearContents
End If
.Range("B4:F4").Copy
rt.PasteSpecial xlPasteFormats
rt = Application.Transpose(a)
.Range(.Range("B3").End(xlDown).Offset(1, 0), .Range("F" & rl)).ClearContents
End With
Else
MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
นั่นไง ผมคงจะโดนเชือดคอโชว์ซะเเล้ว Code: Select all
a(4, lng) = r.Offset(0, -2) And r.Offset(0, -1)ที่อธิบายมาไม่ถูกครับ ที่ดึงข้อมูลมาเก็บไว้ ไม่ได้เก็บไว้ในชีท Form แต่เก็บไว้ใน Array ที่ชือ a โดยเก็บไว้ที่บรรทัดที่ 4 และคอลัมน์ที่ได้จากค่าของ lngbank9597 wrote:
อธิบายตามความเข้าใจของตัวเองเป็นหลักน่ะครับ ถูกหรือผิดหลักอย่างไร รบกวนอาจารย์ชี้แนะอีกครั้งนึงน่ะครับ
ในชีท FORM คอลัมน์ที่ 4 (a(4, lng)) จะดึงข้อมูลมาแสดงข้อมูลในชีท "2703" โดยเลือกคอลัมน์ที่ถัดจากคอลัมน์ "Location" ไปทางซ้าย 2 คอลัมน์(r.Offset(0, -2)) หรือลำดับที่ 2 ก็ได้ ส่วน And r.Offset(0, -1) คือต้องการให้แสดงข้อมูลถัดจากคอลัมน์ "Location" ไปทางซ้าย 1 คอลัมน์ โดยให้ข้อมูล 2 ส่วนนี้แสดงในเซลล์เดียวกันครับCode: Select all
a(4, lng) = r.Offset(0, -2) And r.Offset(0, -1)
เบื้องต้นอธิบายได้แค่นี้ ไม่รู้จะถูกต้องตามที่ต้องการไหม และไม่รู้ถูกต้องตามหลักการที่อาจารย์ท่านได้ถามไหม
ที่อธิบายมาไม่ถูกครับ ที่ดึงข้อมูลมาเก็บไว้ ไม่ได้เก็บไว้ในชีท Form แต่เก็บไว้ใน Array ที่ชือ a โดยเก็บไว้ที่บรรทัดที่ 4 และคอลัมน์ที่ได้จากค่าของ lng
จาก a(4, lng) = r.Offset(0, -2) เป็นการกำหนดค่าให้กับ Array a กรณีต้องการเชื่อมค่าเข้าด้วยกันก่อนที่จะ Assign ค่าให้ใช้ & หรือ +
โดนเชือดจริงๆด้วย 
Code: Select all
Option Explicit
Option Base 1
Sub ShowEmp()
Dim a() As Variant, lng As Long
Dim r As Range, rAll As Range
Dim rt As Range, rl As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
rl = Rows.Count
With Worksheets("2703")
Set rAll = .Range("F2", .Range("F" & rl).End(xlUp))
End With
For Each r In rAll
If r = Worksheets("From").Range("A2") Then
lng = lng + 1
ReDim Preserve a(5, lng)
a(1, lng) = lng
a(2, lng) = r.Offset(0, -4)
a(3, lng) = r.Offset(0, -3)
a(4, lng) = r.Offset(0, -1)
a(5, lng) = r.Offset(0, 0)
End If
Next r
If lng > 0 Then
With Worksheets("From")
Set rt = .Range("B4", .Range("F" & lng - 1 + 4))
If .Range("B4") <> "" Then
.Range("B4", .Range("B" & rl).End(xlUp).Offset(0, 4)).ClearContents
End If
.Range("B4:F4").Copy
rt.PasteSpecial xlPasteFormats
rt = Application.Transpose(a)
.Range(.Range("B3").End(xlDown).Offset(1, 0), .Range("F" & rl)).ClearContents
End With
Else
MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub