iki farklı excel kitap makro düşeyara

[nostram]

merhaba arkadaşlar

aşagıdaki kodu kendi kitabında denedim çalışıyor diğer kitapların kiminde çalışıyor kiminde çalışmıyor

örnek

kıyaslama makrosun kitabında çalışıyor xls

deneme kitabında çalışıyor xlsx

kıyaslanacak liste kitabında çalışmıyor xlsm

sorun kıyaslanacak listenin xls olarak görünmesi acaba aktif çalışma kitabının uzantısını otomatik değiştirp çalıştıran bir kod ekleyebirmisiniz

( kullandığım programda tüm raporlar xls çıkıyor.)




kodlar



Sub DÜŞEY_ARA()

DOSYA_YOLU = CreateObject("wscript.shell").SpecialFolders(0)

Dim s1, s2, son, son1, alan, i As Long
Set s1 = ActiveSheet

yol = ActiveWorkbook.Path
ktp = ActiveWorkbook.Name
Set s2 = Workbooks("KIYASLAMA MAKROSU.xlsm").Sheets("BAZ ALINACAK LİSTE")
Application.ScreenUpdating = False
s1.Range("X:X").ClearContents

son = s1.Cells(Rows.Count, 1).End(xlUp).Row
son1 = s2.Cells(Rows.Count, 1).End(xlUp).Row

'hangi aralıkta çalışacaksan
alan = "a4:W" & son1

For i = 5 To son

'a hücresine göre ara a daki yazanın benzerini

If WorksheetFunction.CountIf(s2.Range("A4:A" & son1), s1.Cells(i, 1)) > 0 Then

'eğer a hücreisnde aynı abone no varsa açık olan sayfanın 24 satırına kıyasladığın sayfadaki 21 satırdaki değeri yaz

s1.Cells(i, 2) = Application.WorksheetFunction.VLookup(s1.Cells(i, 1), s2.Range(alan), 2, 0)


Else

s1.Cells(i, 24) = "KAYDI YOK"


End If
Next

Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, ""
End Sub

 

[nostram]

KONUYU ÇÖZDÜM ARKADAŞLAR


AŞAĞIDAKİ KOM TAM ÇALIŞIYOR

Sub HIZLI_ARA()
Dim Zaman As Double, X As Long, BUL As Range
Dim S1 As Worksheet, S2 As Worksheet, Alan As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Zaman = Timer

Set S1 = Sheets("Data")
Set S2 = Sheets("Statüler")
Set Alan = S2.Range("A2:A1048576")

For X = 2 To S1.Cells(Rows.Count, 1).End(3).Row
Set BUL = Alan.Find(S1.Cells(X, 1), , , xlWhole)
If Not BUL Is Nothing Then
S1.Cells(X, 3) = BUL.Offset(, 2)
S1.Cells(X, 4) = BUL.Offset(, 3)
Else
S1.Cells(X, 3) = "Statüsüz"
S1.Cells(X, 4) = "Statüsüz"
End If
Next

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00"), vbInformation
End Sub



İLGİLİ KODU

http://www.excel.web.tr/f48/vba-ile-en-hyzly-vlookup-yapma-konusunda-yardym-t134766/sayfa2.html

ALDIM YAPAN ARKADAŞLARA TEŞEKKÜR EDERİM