Snasui Excel Forum

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

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

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

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, 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: Select all

Dim i As Integer
    i = 1
    For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    Selection.Copy.Range("A" & i).Value
    Workbooks.Open Filename:= _
        "C:\Documents and Settings\T02083\My Documents\ref.xls"
    Windows("ref.xls").Activate
     If Workbooks("test yes0 t1.xls").Range("A" & i).Value = Range("A" & i).Value Then
     Selection.Copy.Range("B" & i).Value
     Windows("test yes0 t1.xls").Activate
     Range("D" & i).Select
    ActiveSheet.Paste
    Else
    ActiveCell.FormulaRiCi = "no data"
    Rows("i:i").Select
    Selection.Font.ColorIndex = 3
    End If
    Next i
End Sub

Code: Select all

    i = 1
    For i = 1 To Range("C" & Rows.Count).End(xlUp).Row
        If Application.CountIf(Range("C1:C" & i), Cells(i, "C")) > 1 Then
            Cells(i, "C").Clear
        End If
    Next i
    If Application.CountIf(Range("C:C"), "") > 0 Then
        Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If

Code: Select all

i = 1
Do While Cells(i, "C") <> ""
    If Cells(i, "C") = Cells(i + 1, "C") Then
        Cells(i, "C").EntireRow.Delete
    Else
        i = i + 1
    End If
Loop