Snasui Excel Forum

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

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

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

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