Bir sayfadaki numarayı başka sayfada ara bulduklarını başka bir sayfaya listele

[khthonik]

Merhabalar,

Butona basınca;

1) EIRSYZR sayfasında A2 hücresinde yazan irsaliye numarasını, IRSDKM sayfasında X sütununda (5. satırdan itibaren) ara, bulduğun listeyi HKSDKM (5. satırdan itibaren) en alt boş satıra kopyala (kopyalama sırası alttaki gibidir yani IRSDKM sayfasındaki B deki veri HKSDKM sayfasında A ya))

IRSDKM​	HKSDKM​
B​	A​
C​	B​
V​	C​
W​	D​
X​	E​
Y​	F​
Z​	G​
AA​	H​
AB​	I​
AC​	J​
U​	F​

2) HKSDKM sayfasında en altta boş satırların bitmemesi için alttaki gibi kodu da entegre edersek sevinirim.
Dim lastRow As Long
HKSDKM.Rows("1048574:1048576").EntireRow.Delete
lastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1
HKSDKM.Rows(lastRow).Copy HKSDKM.Cells(lastRow + 1, "A") (yada taşıdığı satır kadar en alttaki satırı çoğalt)

 

[khthonik]

Aslında biri bir fikir atsa ortaya kendi excelime göre uyarlarım "Etrafımda fikir alışverişi yapabileceğim kimse yok"

 

[Muzaffer Ali]

Merhaba.
Örnek bir dosya üzerinde sorarsanız daha hızlı ve doğru yanıt alırsınız. Örnek dosyanız gerçeği ile birebir aynı olmalı.
Dosyanızı dosya.co gibi bir paylaşım sitesinde paylaşabilirsiniz.

 

[khthonik]

bir yere kadar yaptım şimdi alttaki kodu her listeyi alt alta ekle şeklinde nasıl revize edebilirim

Sub HakediseAktar()

Dim i As Long, _
j As Long, _
Adt As Integer, _
ShG As Worksheet, _
ShD As Worksheet, _
ShC As Worksheet

Application.ScreenUpdating = False
Application.EnableEvents = False

Set ShG = Sheets("IRSDKM")
Set ShD = Sheets("HKSDKM")
Set ShC = Sheets("EIRSYZR")

ShG.Unprotect Password:="EYIL"
ShD.Unprotect Password:="EYIL"
ShC.Unprotect Password:="EYIL"

ShG.Select

j = ShD.Cells(Rows.Count, "A").End(3).Row
If j < 5 Then j = 5
ShD.Range("A5:K" & j).ClearContents
j = 4

For i = 5 To ShG.Cells(Rows.Count, "A").End(3).Row
If (ShG.Cells(i, "X") >= ShC.Range("A2") And ShG.Cells(i, "X") <= ShC.Range("A2")) Then
j = j + 1
Adt = Adt + 1
ShG.Range("B" & i & ":C" & i).Copy
'ShD.Range("A" & j).PasteSpecial xlPasteFormats
ShD.Range("A" & j).PasteSpecial xlPasteValues
ShG.Range("U" & i & ":AC" & i).Copy
'ShD.Range("C" & j).PasteSpecial xlPasteFormats
ShD.Range("C" & j).PasteSpecial xlPasteValues

ShD.Rows("1048574:1048576").EntireRow.Delete
lastRow = ShD.Cells(Rows.Count, "A").End(xlUp).Row + 1
ShD.Rows(lastRow).Copy ShD.Cells(lastRow + 1, "A")

ShD.Select

End If
Next i

ShG.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True, Password:="EYIL"
ShD.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True, Password:="EYIL"
ShC.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True, Password:="EYIL"

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

 

[khthonik]

alttaki şekilde işimi çözdüm. İlave olarak kodlar; düzenlenebilir, hızlandırılabilir, varsa hatalarım düzeltilebilir, aynı numara tekrar giriş yapılır ise "daha önce işlendi" uyarısı verebilir.

Sub HakediseAktar() ' EIRSYZR sayfasındaki A2 deki irsaliye numarasını IRSDKM sayfasındaki X sütununda ara bu verileri HKSDKM sayfasına taşı

Dim i As Long, _
j As Long, _
lastRow As Long, _
Adt As Integer, _
ShG As Worksheet, _
ShD As Worksheet, _
ShC As Worksheet

Application.ScreenUpdating = False
Application.EnableEvents = False

Set ShG = Sheets("IRSDKM")
Set ShD = Sheets("HKSDKM")
Set ShC = Sheets("EIRSYZR")

ShG.Unprotect Password:="EYIL"
ShD.Unprotect Password:="EYIL"
ShC.Unprotect Password:="EYIL"

ShG.Select

j = ShD.Cells(Rows.Count, "A").End(3).Row

For i = 5 To ShG.Cells(Rows.Count, "A").End(3).Row
If (ShG.Cells(i, "X") >= ShC.Range("A2") And ShG.Cells(i, "X") <= ShC.Range("A2")) Then
j = j + 1
Adt = Adt + 1
ShG.Range("B" & i & ":C" & i).Copy
'ShD.Range("A" & j).PasteSpecial xlPasteFormats
ShD.Range("A" & j).PasteSpecial xlPasteValues
ShG.Range("U" & i & ":AC" & i).Copy
'ShD.Range("C" & j).PasteSpecial xlPasteFormats
ShD.Range("C" & j).PasteSpecial xlPasteValues

ShD.Select

ShD.Rows("1048574:1048576").EntireRow.Delete
lastRow = ShD.Cells(Rows.Count, "A").End(xlUp).Row + 1
ShD.Rows(lastRow).Copy ShD.Cells(lastRow + 1, "A")
End If
Next i

ShG.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True, Password:="EYIL"
ShD.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True, Password:="EYIL"
ShC.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True, Password:="EYIL"

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub