Kapalı Dosyadan İki Tarih Arası Veri Çekme

[ThEeNCi]

İstediğim olmuş fakat açık dosyaya kapalı dosyadan veriyi çekmiyor var olan üstünde düzeltme yapıyor o silinince ord numarası yazıyorum kapalıdan veri gelmiyor

 

[ThEeNCi]

Özür dilerim daha önceki yazdığınız kodla çağıracağım tamam anladım şimdi çok teşekkürler

 

[ThEeNCi]

Tam istediğim gibi oldu ama fakat yanlış bilgi vermişim ord numarasından alt alta bir kaç tane olabiliyor hepsini günceleyecek

 

[asi_kral]

Nasıl yani bunu özellikle sormuştum. Yok demiştiniz değişti mi ?

 

[ThEeNCi]

orayı unuttum fakat ord numarasından alt alta aynı numara var hepsini güncelemiyor

 

[ThEeNCi]

yanlış bilgi vermişim yanlış anladım çünkü

 

[ThEeNCi]

asi_kral birde açık olan dosyadan kapalıya veri atma olursa dört dörtlük olacak veri çekmenin tam tersi karşı taraf daki boş satıra ekleme 3. macro olacak

 

[asi_kral]

Kodu bununla değiştirip dener misiniz ?

Option Explicit
Sub düzenle()
Dim YOL As String, KTP As Workbook, S1 As Worksheet, S2 As Worksheet
Dim STR As Long, SAY As Long, STN As Long
Application.ScreenUpdating = False
YOL = ThisWorkbook.Path & "\"
Set S1 = ActiveSheet
Set KTP = Workbooks.Open(YOL & "kapalı dosya.xlsx")
Set S2 = KTP.Sheets("Sayfa1")
For STR = 7 To S1.Cells(Rows.Count, "A").End(xlUp).Row
For SAY = 2 To S2.Cells(Rows.Count, "A").End(xlUp).Row
If S2.Cells(SAY, "B") = S1.Cells(STR, "B") Then
For STN = 1 To S1.Cells(6, Columns.Count).End(xlToLeft).Column
If S1.Cells(STR, STN) <> "" Then
S2.Cells(SAY, STN) = S1.Cells(STR, STN)
End If: Next
End If: Next: Next
KTP.Save
KTP.Close
Application.ScreenUpdating = True
End Sub

 

[ThEeNCi]

1 satırı güncelleyince bütün satırları aynı güncelleme yapıyor olmuyor yani

 

[asi_kral]

1 satırı güncelleyince bütün satırları aynı güncelleme yapıyor olmuyor yani

Peki bunu nasıl ayırt edeceksiniz onu da söylerseniz.

 

[ThEeNCi]

Alış tutarları ve kilo da olabilir onlar hep değişik veya en sona sıra no diye sütünda ekleyebiliriz

 

[asi_kral]

Alış tutarları ve kilo da olabilir onlar hep değişik veya en sona sıra no diye sütünda ekleyebiliriz

Standart bir yeriniz olsun.
Dosyanızı buna göre hazırlayın gönderin bakalım.

 

[ThEeNCi]

Ekledim birde 3. macro ile açık dosyadan kapalı dosyaya veri yollama boş satıra ama

 

[asi_kral]

Bir yanlışlık yok mu sizce ?
Benim gördüğüm sıra numarası kapalı dosyada olmalı veriler kapalı dosyada güncelleyeceği için öyle düşündüm.
3. Makro derken anlamadım.

 

[ThEeNCi]

Ona eklemeyi unutmuşum 3. macroda açık dosyadan kapalı dosyaya veri aktarma burdan yeni ord numaralı bir kayır girince kapalı dosyaya atma

 

[asi_kral]

Merhaba
Sayfadaki İMAGE kodunu bununla değiştirin.

Option Explicit
Private Sub Image1_Click()
Dim YOL As String, KTP As Workbook, S1 As Worksheet, S2 As Worksheet
Dim STR As Long, SBT As Variant
Application.ScreenUpdating = False
YOL = ThisWorkbook.Path & "\"
Set S1 = ActiveSheet
SBT = ActiveCell.Address
S1.Range("A7:X" & Rows.Count).ClearContents
Set KTP = Workbooks.Open(YOL & "kapalı dosya.xlsx")
Set S2 = KTP.Sheets("Sayfa1")
STR = S2.Range("A" & Rows.Count).End(xlUp).Row
S2.Range("A1:X" & STR).AutoFilter 3, ">=" & S1.Range("A4"), xlAnd, "<=" & S1.Range("B4")
If WorksheetFunction.Subtotal(3, S2.Range("A2:A" & STR)) > 0 Then
S2.Range("A2:X" & STR).Copy: S1.Range("A7").PasteSpecial
End If
S2.Range("A1:X" & STR).AutoFilter
KTP.Close 0
Range(SBT).Select
Application.ScreenUpdating = True
End Sub

 

[asi_kral]

Module de olan kodu

Option Explicit
Sub düzenle()
Dim YOL As String, KTP As Workbook, S1 As Worksheet, S2 As Worksheet
Dim STR As Long, SAY As Long, STN As Long, STR1 As Long
Application.ScreenUpdating = False
YOL = ThisWorkbook.Path & "\"
Set S1 = ActiveSheet
Set KTP = Workbooks.Open(YOL & "kapalı dosya.xlsx")
Set S2 = KTP.Sheets("Sayfa1")
For STR = 7 To S1.Cells(Rows.Count, "A").End(xlUp).Row
For SAY = 2 To S2.Cells(Rows.Count, "A").End(xlUp).Row
If WorksheetFunction.CountIf(S2.Range("C:C"), S1.Cells(STR, "C")) > 0 Then
If S2.Cells(SAY, "C") = S1.Cells(STR, "C") And _
S2.Cells(SAY, "A") = S1.Cells(STR, "A") Then
For STN = 1 To S1.Cells(6, Columns.Count).End(xlToLeft).Column
If S1.Cells(STR, STN) <> "" Then
S2.Cells(SAY, STN) = S1.Cells(STR, STN)
End If: Next: End If
Else
STR1 = S2.Range("A" & Rows.Count).End(xlUp).Row + 1
For STN = 1 To S1.Cells(6, Columns.Count).End(xlToLeft).Column
If S1.Cells(STR, STN) <> "" Then
S2.Cells(STR1, STN) = S1.Cells(STR, STN)
End If: Next
End If
Next: Next
KTP.Save
KTP.Close
Application.ScreenUpdating = True
End Sub

Bununla değiştirin.

 

[asi_kral]

Üstteki kodu tekrar güncelledim.
3. Kodu eklemeyi unutmuştum son anda aklıma geldi. Ekleme yapıldı koda
Dosya ekliyorum

 

[ThEeNCi]

Bunlar tamamdır 3. macro açık sayfadan kapalı sayfaya yeni ord numarası ile boş olan satıra ekleme

 

[ThEeNCi]

Tamamdır çok sağol mükemmel oldu çok yordum sizi kusura bakmayın saygılarımla