Formulu Butun verili Stuna karsisina kopyala

[lapot]

Arkadaslar ekdeki dosyada bazi veriler var. Benim amacim E2 deki formulu en son verinin oldugu hucreye kadar kopyalamak. Ama bunu hucrenin kosesindeki Arti'ya tiklamayala yapmak istemiyorum cunku dosyanin boyu bazen degisiyor ve bu tiklama bazan yariya kadar formulu kopyaliyor.

Acaba kopyalamnin baska bir yolu varmi, formulu sadece veri olan hucreye kadar indirmek icin?

yardimlariniz icin cok tesekkurler

 

[İhsan Tank]

diğer dosyanızı ekler misiniz.

 

[lapot]

bu dosya calismiyor mu.

 

[lapot]

ornekdeki diger dosyayi veremiyorum cunku ismiler ozel. (confidential)

 

[İhsan Tank]

ornekdeki diger dosyayi veremiyorum cunku ismiler ozel. (confidential)

bağlantı kurmuşsunuz
bende bunu makro'ya tanıtacağım ki dosyadan verileri çeksin.
siz diyorsunuz ya ben elle yapmak istemiyorum diye otomatik olsun diye onun için gerekli
o dosyanın içindeki isimleri değiştirip ekleyin yoksa tek bu dosyada size nasıl yardım edeceğim bilmiyorum.

asıl verilerinizin yerini hayali verilerle doldurup gönderin yada ona benzer bir dosya oluşturun

 

[lapot]

Dosyayi guncelledim, ve Sheet3 veriler koydum , cok tesekkurler simdiden

 

[İhsan Tank]

Dosyayi guncelledim, ve Sheet3 veriler koydum , cok tesekkurler simdiden

merhaba
boş bir module kopyalayın ve buton'a atayarak deneyin.

Option Explicit
Sub karşılık()
Dim ts, kaplan
kaplan = MsgBox("Karşılıklarını Çıkarıyorum", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
Application.DisplayAlerts = False
Sheets("Sheet1").Range("E2:E65536").ClearContents
For ts = 2 To Sheets("Sheet1").Cells(65536, "D").End(xlUp).Row
If WorksheetFunction.CountIf(Sheets("Sheet3").Range("A:A"), _
Sheets("Sheet1").Cells(ts, "D")) > 0 Then
Sheets("Sheet1").Cells(ts, "E") = WorksheetFunction.VLookup(Sheets( _
"Sheet1").Cells(ts, "D"), Sheets("Sheet3").Range("A:C"), 3, 0)
End If
Next
Application.DisplayAlerts = True
MsgBox "Karşıkları Çıkarttım", vbInformation, "Bitiş"
End Sub

 

[lapot]

Ihsan bey cok tesekkurler yardiminiz icin fakat benim original dosyada Sheet1'in ismi BillsBook and Sheet3'nin ismi UserDepartments. ben bunlari asagidaki gibi degistirdim macro istenilen gibi calaismadi. Acaba neden?

Option Explicit
Sub karsilik()
Dim ts, kaplan
kaplan = MsgBox("Karsiliklarini Çikariyorum", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
Application.DisplayAlerts = False
Sheets("BillsBook").Range("E2:E65536").ClearContents
For ts = 2 To Sheets("BillsBook").Cells(65536, "D").End(xlUp).Row
If WorksheetFunction.CountIf(Sheets("UserDepartments").Range("A:A"), _
Sheets("BillsBook").Cells(ts, "D")) > 0 Then
Sheets("BillsBook").Cells(ts, "E") = WorksheetFunction.VLookup(Sheets( _
"BillsBook").Cells(ts, "D"), Sheets("UserDepartments").Range("A:C"), 3, 0)
End If
Next
Application.DisplayAlerts = True
MsgBox "Karsiklari Çikarttim", vbInformation, "Bitis"
End Sub

 

[İhsan Tank]

Ihsan bey cok tesekkurler yardiminiz icin fakat benim original dosyada Sheet1'in ismi BillsBook and Sheet3'nin ismi UserDepartments. ben bunlari asagidaki gibi degistirdim macro istenilen gibi calaismadi. Acaba neden?

Option Explicit
Sub karsilik()
Dim ts, kaplan
kaplan = MsgBox("Karsiliklarini Çikariyorum", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
Application.DisplayAlerts = False
Sheets("BillsBook").Range("E2:E65536").ClearContents
For ts = 2 To Sheets("BillsBook").Cells(65536, "D").End(xlUp).Row
If WorksheetFunction.CountIf(Sheets("UserDepartments").Range("A:A"), _
Sheets("BillsBook").Cells(ts, "D")) > 0 Then
Sheets("BillsBook").Cells(ts, "E") = WorksheetFunction.VLookup(Sheets( _
"BillsBook").Cells(ts, "D"), Sheets("UserDepartments").Range("A:C"), 3, 0)
End If
Next
Application.DisplayAlerts = True
MsgBox "Karsiklari Çikarttim", vbInformation, "Bitis"
End Sub

merhaba
kod bende gayet güzel çalıştı
üstte kırmızı ya boyadığın yer mavi yer ile eşit değil nasıl kod çalışsın ki

Option Explicit
Sub karşılık()
Dim ts, kaplan
kaplan = MsgBox("Karşılıklarını Çıkarıyorum", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
Application.DisplayAlerts = False
Sheets("BillsBook").Range("E2:E65536").ClearContents
For ts = 2 To Sheets("BillsBook").Cells(65536, "D").End(xlUp).Row
If WorksheetFunction.CountIf(Sheets("UserDepartments.").Range("A:A"), _
Sheets("BillsBook").Cells(ts, "D")) > 0 Then
Sheets("BillsBook").Cells(ts, "E") = WorksheetFunction.VLookup(Sheets( _
"BillsBook").Cells(ts, "D"), Sheets("UserDepartments.").Range("A:C"), 3, 0)
End If
Next
Application.DisplayAlerts = True
MsgBox "Karşıkları Çıkarttım", vbInformation, "Bitiş"
End Sub

 

[lapot]

Evet ihsan bey ornek dosyada calisiyor, bendekinin stun harfleri formulle tutmuyor onlari ayarlamam lazim

cok tesekkurler, saygilar.

 

[İhsan Tank]

Evet ihsan bey ornek dosyada calisiyor, bendekinin stun harfleri formulle tutmuyor onlari ayarlamam lazim

cok tesekkurler, saygilar.

sütunlar farklı ise doğrudur çalışmaz onada benim yapacak bir şeyim kalmaz
rica ederim
:yazici: