Makro ile veri aktarımı

[selim_1]

Arkadaşlar ekteki dosyada "Order Record" sheetindeki bir satır üzerinde çift tıkladığımda o satırdaki bilgileri Archive e makro vasıtasıyla atıyor fakat ben bu şekilde değilde satırın en sonundaki kolona "OK"yazıp enter a bastığımda archive atmasını istiyorum.
Yardım ederseniz sevinirim.Sitede çok örnek var ama hiç birini bu dosyaya uyduramadım.
şu anda kullandığım makro ekte.
'
'Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error GoTo Son
If Intersect(Target, [A:u]) Is Nothing Then Exit Sub
Set s2 = Sheets("Arsiv")
SatirNo = s2.[A65536].End(3).Row + 1
If SatirNo < 5 Then SatirNo = 5
Range("A" & Target.Row & ":U" & Target.Row).Cut s2.Range("A" & SatirNo)
Son:
End Sub

 

[selim_1]

dosya ekleyememiştim.

 

[İhsan Tank]

dosya ekleyememiştim.

merhaba

Order Record

bu sayfanın kod bölümüne uygulayın

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("M5:M65536")) Is Nothing Then Exit Sub
Dim ts, kaplan
kaplan = 5
For ts = 5 To Cells(65536, "M").End(xlUp).Row
If Cells(ts, "M") = "OK" Then
Sheets("Archive").Cells(kaplan, "A") = Cells(ts, "A")
Sheets("Archive").Cells(kaplan, "B") = Cells(ts, "B")
Sheets("Archive").Cells(kaplan, "C") = Cells(ts, "C")
Sheets("Archive").Cells(kaplan, "D") = Cells(ts, "D")
Sheets("Archive").Cells(kaplan, "E") = Cells(ts, "E")
Sheets("Archive").Cells(kaplan, "F") = Cells(ts, "F")
Sheets("Archive").Cells(kaplan, "G") = Cells(ts, "G")
Sheets("Archive").Cells(kaplan, "H") = Cells(ts, "H")
Sheets("Archive").Cells(kaplan, "I") = Cells(ts, "I")
Sheets("Archive").Cells(kaplan, "J") = Cells(ts, "J")
Sheets("Archive").Cells(kaplan, "K") = Cells(ts, "K")
Sheets("Archive").Cells(kaplan, "L") = Cells(ts, "L")
Sheets("Archive").Cells(kaplan, "M") = Cells(ts, "M")
kaplan = kaplan + 1
End If
Next
End Sub

 

[selim_1]

İhsan Bey
Yardımlarınız için teşekkürler fakat çalışmadı.Benim excelim türkçe 2007 ondan olabilirmi ?

 

[İhsan Tank]

İhsan Bey
Yardımlarınız için teşekkürler fakat çalışmadı.Benim excelim türkçe 2007 ondan olabilirmi ?

eki inceler misiniz

 

[sicilyali]

Yararlı bir paylaşım elinize sağlık.

 

[İhsan Tank]

Yararlı bir paylaşım elinize sağlık.

kolay gelsin
:yazici:

 

[selim_1]

Teşekkürler İhsan Bey.
Aslında ben ilk sayfadan kopyalanan satırın silinip diğer sayfaya aktarılmasını istemiştim ama yinede teşekkürler.Bu çalışma bana fikir verdi diğer tarafınıda ben hallederim.

 

[İhsan Tank]

Teşekkürler İhsan Bey.
Aslında ben ilk sayfadan kopyalanan satırın silinip diğer sayfaya aktarılmasını istemiştim ama yinede teşekkürler.Bu çalışma bana fikir verdi diğer tarafınıda ben hallederim.

ne yapmak isterdiğinizi ben bu şekilde anladım. siz diğer sayfada verilerin kalmasını istemiyorsanız onu halletmesi kolay siz yaparım derseniz olur tabi
rica ederim
:yazici:

 

[onurcan1979]

merhaba
bu sayfanın kod bölümüne uygulayın

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("M5:M65536")) Is Nothing Then Exit Sub
Dim ts, kaplan
kaplan = 5
For ts = 5 To Cells(65536, "M").End(xlUp).Row
If Cells(ts, "M") = "OK" Then
Sheets("Archive").Cells(kaplan, "A") = Cells(ts, "A")
Sheets("Archive").Cells(kaplan, "B") = Cells(ts, "B")
Sheets("Archive").Cells(kaplan, "C") = Cells(ts, "C")
Sheets("Archive").Cells(kaplan, "D") = Cells(ts, "D")
Sheets("Archive").Cells(kaplan, "E") = Cells(ts, "E")
Sheets("Archive").Cells(kaplan, "F") = Cells(ts, "F")
Sheets("Archive").Cells(kaplan, "G") = Cells(ts, "G")
Sheets("Archive").Cells(kaplan, "H") = Cells(ts, "H")
Sheets("Archive").Cells(kaplan, "I") = Cells(ts, "I")
Sheets("Archive").Cells(kaplan, "J") = Cells(ts, "J")
Sheets("Archive").Cells(kaplan, "K") = Cells(ts, "K")
Sheets("Archive").Cells(kaplan, "L") = Cells(ts, "L")
Sheets("Archive").Cells(kaplan, "M") = Cells(ts, "M")
kaplan = kaplan + 1
End If
Next
End Sub

Arkadaşlar böyle bir kodu kullanarak başka bir kapalı dosyadan nasıl veri alış verişini nasıl sağlarız?

 

[onurcan1979]

günaydın arkadaşlar

 

[assenucler]

Sayın İhsan Tank;

İyi bayramlar... Katkılarınız için teşekkürler.

 

[İhsan Tank]

Arkadaşlar böyle bir kodu kullanarak başka bir kapalı dosyadan nasıl veri alış verişini nasıl sağlarız?

Sayın Onurcan1979
Lütfen yeni bir konu açarak sorunuzu sorunuz. Ayrıca dosya eklemeyi unutmazsanız yardım almanız daha kolay olacaktır.

 

[İhsan Tank]

Sayın İhsan Tank;

İyi bayramlar... Katkılarınız için teşekkürler.

Rica ederim
Yardımcı olabiliyorsam ne mutlu bana
:keyif:

 

[onurcan1979]

merhaba
bu sayfanın kod bölümüne uygulayın

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("M5:M65536")) Is Nothing Then Exit Sub
Dim ts, kaplan
kaplan = 5
For ts = 5 To Cells(65536, "M").End(xlUp).Row
If Cells(ts, "M") = "OK" Then
Sheets("Archive").Cells(kaplan, "A") = Cells(ts, "A")
Sheets("Archive").Cells(kaplan, "B") = Cells(ts, "B")
Sheets("Archive").Cells(kaplan, "C") = Cells(ts, "C")
Sheets("Archive").Cells(kaplan, "D") = Cells(ts, "D")
Sheets("Archive").Cells(kaplan, "E") = Cells(ts, "E")
Sheets("Archive").Cells(kaplan, "F") = Cells(ts, "F")
Sheets("Archive").Cells(kaplan, "G") = Cells(ts, "G")
Sheets("Archive").Cells(kaplan, "H") = Cells(ts, "H")
Sheets("Archive").Cells(kaplan, "I") = Cells(ts, "I")
Sheets("Archive").Cells(kaplan, "J") = Cells(ts, "J")
Sheets("Archive").Cells(kaplan, "K") = Cells(ts, "K")
Sheets("Archive").Cells(kaplan, "L") = Cells(ts, "L")
Sheets("Archive").Cells(kaplan, "M") = Cells(ts, "M")
kaplan = kaplan + 1
End If
Next
End Sub

İlhan bey Merhaba sizden bir iricam var veya bu işlemi yapa bilecek bir üstadtan yukarıdaki kodla aşağdaki belirteceğim kodun birleşimi bir süzme işlemi yaptırmak istiyorum formu baştan aşağı taradım ama bulamadım
benim istediğim sizinki gibi aktarmak istediğim verileri istediğim sütunlara süzmesi yapmak fakat benim gireceğim kriterlere göre bunuda aşağıdaki kod yapıyor ama ben bütün bir sayfayı süzmek değil benim belirleyeceğim sayfaları süzmek istiyorum tek bir sürun üzerinden kriter taraması yapacak ve onun karşılığındaki verileri aktaracak

On Error Resume Next
If Intersect(Target, [J3]) Is Nothing Then Exit SubApplication.ScreenUpdating = False
Set s1 = Sheets("SERVİSE.GİDEN")
Range("A8:M65536").ClearContents
Set Aralik = s1.Range("A2:A" & s1.[A65536].End(3).Row)
Set Bul = Aralik.Find(Target.Text, LookAt:=xlWhole)
If Not Bul Is Nothing Then
Adres = Bul.Address
Do
sat = [A65536].End(3).Row + 1
s1.Range(s1.Cells(Bul.Row, "A"), s1.Cells(Bul.Row, "M")).Copy
Cells(sat, "A").PasteSpecial Paste:=xlValues
Set Bul = Aralik.FindNext(Bul)
Loop While Not Bul Is Nothing And Bul.Address <> Adres
Application.CutCopyMode = False
MsgBox "DİSİPLİN İşlem tamam.", vbInformation, "RAPOR DURUMU"
End If

 

[relaxim]

Sanırım bu mesajı görmediniz.

Sayın Onurcan1979
Lütfen yeni bir konu açarak sorunuzu sorunuz. Ayrıca dosya eklemeyi unutmazsanız yardım almanız daha kolay olacaktır.

 

[onurcan1979]

haklısınız gözden kaçmış yorgunluğun verdiği dikkatsizlik işte uyarınız için teşekkürler. konuyu akşam açarım iyi günler