ขอความช่วยเหลือการเขียนโปรแกรมหาข้อมูลครับ

[tupthai]

Code: Select all

Public Sub Compare()
Dim wb1, wb2 As Workbook
Dim Path, Filename As String
Dim i, j, c, f, LastRow1, LastRow2 As Integer

Application.ScreenUpdating = False
Path = "[color=#BFFF00]D:\[/color]"
Filename = Dir(Path & "*.xls")

Set wb1 = ActiveWorkbook
LastRow1 = wb1.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
c = 4
Do While Filename <> ""
Set wb2 = Workbooks.Open(Path & Filename, False, False)
LastRow2 = wb2.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow1
    For j = 2 To LastRow2
        If wb1.Sheets(1).Cells(i, 1).Value = wb2.Sheets(1).Cells(j, 1).Value Then
           wb1.Sheets(1).Cells(i, c).Value = wb2.Sheets(1).Cells(j, 2).Value
           wb1.Sheets(1).Cells(i, c).Font.ColorIndex = 1
           f = 1
        End If
    Next j
   If f = 0 Then
        wb1.Sheets(1).Cells(i, c).Value = "No Data"
        wb1.Sheets(1).Cells(i, c).Font.ColorIndex = 3
   End If
   f = 0
Next i
wb1.Sheets(1).Cells(1, c).Value = Filename
wb2.Close False
Filename = Dir
c = c + 1
Loop
Application.ScreenUpdating = True
  
End Sub

พอดีว่างๆ ผมลองทำแบบหา file excel ที่อยู่ใน folder เดียวกันแล้วนำมาเปรียบเทียบทีละไฟล์
แล้วนำผลลัพท์ มาไว้ที่ คอลัมท์ถัดไป

[snasui]

Code: Select all

Path = "[color=#BFFF00]D:\[/color]"

ในการ Post เป็น Code VBA ไม่สามารถจัดรูปแบบได้ครับ

Code: Select all

Dim wb1, wb2 As Workbook
Dim Path, Filename As String
Dim i, j, c, f, LastRow1, LastRow2 As Integer

ขอเสริมเรื่องการประกาศตัวแปรใน VBA เพื่อประโยชน์กับท่านอื่น ๆ ครับ

จากการประกาศตัวแปรด้านบน

wb1, Path, i, j, c, f, LastRow1 จะเป็น Variant ทั้งหมดครับ หากผมเข้าใจถูกต้อง คุณ tupthai ต้องการจะประกาศเป็นตามด้านล่าง

Code: Select all

Dim wb1 As Workbook, wb2 As Workbook
Dim Path As String, Filename As String
Dim i As Integer, j As Integer, c As Integer, f As Integer
Dim LastRow1 As Integer, LastRow2 As Integer

[pichetppp]

Code: Select all

Dim wb1, wb2 As Workbook

Application.ScreenUpdating = False
Set wb1 = ActiveWorkbook
LastRow1 = wb1.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
Set wb2 = Workbooks.Open("C:\Documents and Settings\My Documents\ref.xls", False, False)
LastRow2 = wb2.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To LastRow1
    For j = 1 To LastRow2
        If wb2.Sheets(1).Range("A" & j).Value = wb1.Sheets(1).Range("A" & i).Value Then
           wb1.Sheets(1).Range("D" & i).Value = wb2.Sheets(1).Range("B" & j).Value
           f = 1
        End If
    Next j
   If f = 0 Then
        wb1.Sheets(1).Range("D" & i).Value = "no data"
        wb1.Sheets(1).Range("D" & i).Font.ColorIndex = 3  
   End If
   f = 0
Next i

wb2.Close False
Application.ScreenUpdating = True

ขอบคุณครับ
ผมลองแก้ไขตาม code นี่แล้ว และปรับการแสดงสีแดงบนตัวอักษร ให้เป็น

Code: Select all

If wb1.Sheets(1).Range("D" & i).Value = "" Then
            wb1.Sheets(1).Range("D" & i).Value = "NO DATA"
            wb1.Sheets(1).Range("D" & i).Font.ColorIndex = 3
            wb1.Sheets(1).Range("A" & i).Font.ColorIndex = 3
   End If

งานผมก็ไปต่อได้ง่ายขึ้นแล้วครับ
ขอบคุณครับ
(แล้วจะมาถามต่อครับ)

[pichetppp]

สวัสดีครับ อาจารย์และท่านผู้ช่วยเหลือผมทุกท่าน
ตอนนี้ผมสามารถทำให้ได้ใกล้เคียงกับสิ่งที่ได้ถามไว้ตั้งแต่เริ่มกระทู้แล้วครับ
ได้ code ดังนี้ครับ

Code: Select all

Private Sub InputBox1_Change()
Dim x As String
x = InputBox1.Value
End Sub

Private Sub InputBox2_Change()
Dim y As String
y = InputBox2.Value
End Sub

Private Sub CommandButton1_Click()
    Call FindLink
End Sub

Public Sub FindLink()
Dim wb1, wb2, wb3 As Workbook
x = InputBox1.Value
y = InputBox2.Value
Const filepath = "C:\Documents and Settings\My Documents\DATA\"
Application.ScreenUpdating = False
Set wb1 = Workbooks.Open(filepath & x & ".xls", False, False)
LastRow1 = wb1.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
Set wb3 = Workbooks.Open("C:\Documents and Settings\My Documents\DATA\data.xls", False, False)
LastRow3 = wb3.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow1
    For j = 1 To LastRow3
        If wb3.Sheets(1).Range("B" & j).Value = wb1.Sheets(1).Range("B" & i).Value Then
           wb1.Sheets(1).Range("D" & i).Value = wb3.Sheets(1).Range("D" & j).Value
        End If
    Next j
   If wb1.Sheets(1).Range("D" & i).Value = "" Then
            wb1.Sheets(1).Range("D" & i).Value = "-"
            wb1.Sheets(1).Range("D" & i).Font.ColorIndex = 3
            wb1.Sheets(1).Range("B" & i).Font.ColorIndex = 3
            wb1.Sheets(1).Range("C" & i).Font.ColorIndex = 3
   End If
Next i
wb3.Close False
Application.ScreenUpdating = True
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(filepath & y & ".xls", False, False)
LastRow2 = wb2.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
Set wb3 = Workbooks.Open("C:\Documents and Settings\My Documents\DATA\data.xls", False, False)
LastRow3 = wb3.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow2
    For j = 1 To LastRow3
        If wb3.Sheets(1).Range("B" & j).Value = wb2.Sheets(1).Range("B" & i).Value Then
           wb2.Sheets(1).Range("D" & i).Value = wb3.Sheets(1).Range("D" & j).Value
        End If
    Next j
   If wb2.Sheets(1).Range("D" & i).Value = "" Then
            wb2.Sheets(1).Range("D" & i).Value = "-"
            wb2.Sheets(1).Range("D" & i).Font.ColorIndex = 3
            wb2.Sheets(1).Range("B" & i).Font.ColorIndex = 3
            wb2.Sheets(1).Range("C" & i).Font.ColorIndex = 3
   End If
Next i
wb3.Close False
End Sub

แต่ผมคิดว่ามันน่าจะมีการแก้แน่เลย แต่ผมยังแค่เริ่มต้นและใช้เวลา 2 สัปดาห์ ลองผิดลองถูกจากคำแนะนำของอาจารย์ ผู้รู้ทุกท่านและหนังสืออีกเล่มที่พอหาได้ ทำให้บรรลุเป้าหมายการทำ
ต้องขอบคุณมากๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆๆ เลยครับ
หากอาจารย์หรือผู้ที่ดูกระทู้นี้อยากแนะนำติหรือแก้ไข ให้มีการพัฒนาต่อไปแนะนำกันด้วยนะครับ

ตอนนี้ผมปีนภูเขาถึงยอดแรกแล้ว ส่วนจะมีลูกถัดไปหรือไม่นั้นคงต้องสุดแล้วแต่โอกาสที่จะทำให้เราต้องปีนมันแล้วไปให้ถึง
ขอบคุณอีกครั้งครับ