Keskustelu: Ohjelmointikysymykset: VB6: Kahden excelin vertailu

Dim xx As Long


Sub etsi()

  Dim LastRow As Long
  Dim x As Long
  Dim nimi As String
  Const NIMICOLUMN = 1
  Const Sheet1 = "Sheet1"
  Const Workbook1 = "omaapteekit.xlsm"

 Windows(Workbook1).Activate

    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    Set shtJt = ActiveWorkbook.ActiveSheet
   For x = 2 To LastRow
   nimi = shtJt.Cells(x, NIMICOLUMN)
   etsikohde nimi, Workbook1, Sheet1, x
   Next x


End Sub

Sub etsikohde(nimi As String, Workbook1 As String, Sheet1 As String, pos As Long)

Const Workbook2 = "names.xlsx"
Const sheet2 = "nimilista"
Dim LastRow As Long
Dim x As Long

Const nimi = 1
Const nimi2 = 2
Const nimi3 = 3
Const nimi4 = 4
Const nimi5 = 5
Const nimi6 = 6
Const nimi7 = 7
Const nimi8 = 8
Const nimi9 = 9
Const nimi10 = 10
Const nimi11 = 4
Const nimi12 = 4

Windows(Workbook2).Activate

'Worksheets(Workbook2).Activate

  Sheets(sheet2).Select
     With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
   Set shtJt = ActiveWorkbook.ActiveSheet
For x = 16 To LastRow
 xx = xx + 1
 If xx > 10000 Then
  DoEvents ' tee tätä vain silloin tällöin
   xx = 0
 End If

 If etsimonta(nimi, x, nimi) = 1 Then
 Workbooks(Workbook1).Sheets(Sheet1).Cells(pos, ALKUSARAKE) = shtJt.Cells(x, nimi4)
  Workbooks(Workbook1).Sheets(Sheet1).Cells(pos, ALKUSARAKE + 1) = shtJt.Cells(x, nimi5)
 Workbooks(Workbook1).Sheets(Sheet1).Cells(pos, ALKUSARAKE + 2) = shtJt.Cells(x, nimi6)

  Workbooks(Workbook1).Sheets(Sheet1).Cells(pos, ALKUSARAKE + 4) = shtJt.Cells(x, nimi7)
  Workbooks(Workbook1).Sheets(Sheet1).Cells(pos, ALKUSARAKE + 5) = shtJt.Cells(x, nimi8)
 Workbooks(Workbook1).Sheets(Sheet1).Cells(pos, ALKUSARAKE + 6) = shtJt.Cells(x, nimi9)
  Workbooks(Workbook1).Sheets(Sheet1).Cells(pos, ALKUSARAKE + 7) = shtJt.Cells(x, nimi10)
  Workbooks(Workbook1).Sheets(Sheet1).Cells(pos, ALKUSARAKE + 8) = shtJt.Cells(x, nimi11)


 Exit Sub

 End If



Next x


End Sub

Function etsimonta(nimi As String, pos As Long, nimi As Integer) As Integer

Dim len1 As Integer
Dim strings(20) As String
Dim nimi As String
Dim rng As String
Dim x As Integer

Set shtJt = ActiveWorkbook.ActiveSheet

rng = "D" + Format(pos)

On Error GoTo loppu

nimi = shtJt.Cells(pos, nimi)


With Worksheets(1).Range(rng)
    Set c = .Find(nimi, LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do

            Set c = .FindNext(c)
            If c <> "" Then x = x + 1

        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
etsimonta = x

Exit Function

loppu:
 etsimonta = 0



End Function



Sub cc()
Dim nimi As String
Dim x As Integer
Dim rng As String
rng = "D" + Format(16)



With Worksheets(1).Range(rng)
    Set c = .Find(nimi, LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do

            Set c = .FindNext(c)
            If c <> "" Then x = x + 1

        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With

End Sub