Hücre Seç ve Aktar

[xlsx]

Sn Halit3
Birden fazla aktarma seçeneği içersinde 2.aktarılan kelimeye göre renkli yap aktar formüller hariç seçeneği ile istediğim işlemi ve fazlasını yapabildim elinize sağlık.Tşk

 

[ilobilo]

Emeklerinize Sağlık Gayet Güzel Çalışmalar Ortaya Çıkıyor.Seç ve Aktara benzer bir çalışma daha ekledim, Umarım Çok Kişininde işine Yaracayaktır. İlgilenirseniz Sevinirim. Saygılarımla.

 

[halit3]

bununla ilgili örnek var zaten

 

[halit3]

kelime değil değilmi yanlızca hücrenin tamamını kapsayacak

 

[halit3]

ekli dosyanızı kontrol ediniz,

 

[ilobilo]

Halit bey merhaba Öncelikle ilginiz için teşekkürler. Benim Anlatmak istediğim Bu Değildi, Yine Örnek ile Ekli Dosyada Anlatmaya Çalıştım. Saygılarımla.

 

[halit3]

dosya açağıda

 

[ilobilo]

Teşekkürler

 

[halit3]

seç ve aktarda son dosya

 

[xlsx]

Halit3 çalışmanız daha önce hazır mıydı yoksa sonradan mı yaptınız bilemiyorum ama elinize sağlık, çok işimize yarayacak.Tşk

 

[yusufbayram]

hocam saol

 

[ilobilo]

Herkese Tekrar Merhabalar,
Hücre aktar ile ilgili farklı bir çalışma istiyorum.
Örnek anlatımı ile ekli Dosyadır. Şimdiden Kolay Gelsin.

 

[halit3]

aradığınız bu kodmu

Sub aktar()
Dim s As Integer
Dim t As String
a = MsgBox("İşlemi aktarmak İstiyormusunuz..?", vbYesNo, C & " Hücresi")
If a = vbNo Then
Exit Sub
End If
sat = WorksheetFunction.CountA(Worksheets("Sayfa2").Range ("A2:A65000")) + 2
sutun_sayısı = 6
For j = 1 To sutun_sayısı
t = Columns(j).Address(0, 0)
m = Left(t, InStr(t, ":") - 1)
For i = 1 To WorksheetFunction.CountA(Worksheets("Sayfa1").Range (m & "1:" & m & "65000")) + 1
Worksheets("Sayfa2").Cells(sat, i + 1).Value = Worksheets("Sayfa1").Cells(i, 2)
Worksheets("Sayfa2").Cells(sat, i + 7).Value = Worksheets("Sayfa1").Cells(i, 3)
Worksheets("Sayfa2").Cells(sat, i + 13).Value = Worksheets("Sayfa1").Cells(i, 4)
Next i
Next j
Worksheets("Sayfa2").Cells(sat, 1).Value = sat - 1
End Sub

 

[ilobilo]

Bu Kodlar çalışmadı. Örnek Dosya ile gönderebilirmisiniz.

 

[halit3]

sistem bazı formüllerin arasını açıyor

sat = WorksheetFunction.CountA(Worksheets("Sayfa2").Rang e("A2:A65000")) + 2
For i = 1 To WorksheetFunction.CountA(Worksheets("Sayfa1").Rang e(m & "1:" & m & "65000")) + 1

bu kodlar muhtemelen kırmızı olmuştur

Rang e yazan yerlerin arası açık yapmış sistem sen bunların arasındaki boşluğu al yanı kapat

aşağıdaki gibi yap
Range

 

[ilobilo]

Evet dediğiniz şekilde yaptım açlıştı Aktarıyor ama Yazılanları silmesi gerek. Önceki Hüceryi temizliyordu şimdi yazılanlar aynı kalıyor.

 

[halit3]

makronun ilk başına yanı
Sub aktar() bunun hemen altına

aşağıdaki kodu koy


Worksheets("Sayfa2").Range("A2:S500").ClearContents