Kapalı Dosyadan İki Tarih Arası Veri Çekme

[asi_kral]

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

Kolay Gelsin.
İşinizi gördüyse yorulmak mühim değil.

 

[ThEeNCi]

Denemelerini yaptım fakat 3. macro istediğim olayda 1 satırı kapalı dosyaya tek satır aktarıyor bir den fazla ekleme olabiliyor onu güncellemeden ayrı 3. macro yapsak olurmu

 

[asi_kral]

Denemelerini yaptım fakat 3. macro istediğim olayda 1 satırı kapalı dosyaya tek satır aktarıyor bir den fazla ekleme olabiliyor onu güncellemeden ayrı 3. macro yapsak olurmu

İçerisine ekledim.
Öyle olmayacak mıydı ?

 

[ThEeNCi]

1.Satırı kapalı dosyaya aktarıyor 2. satırı görmüyor

 

[ThEeNCi]

yeni kayıt da çalışmıyor güncellemede çalışıyor

 

[asi_kral]

1.Satırı kapalı dosyaya aktarıyor 2. satırı görmüyor

Nasıl aktarmıyor mutlaka bir şey vardır.
Aynı Ord numarası vardır. Olmayan bir ord yazdığınızda ona göre işlem yapar.
Ama aynı ord den birden fazla kayıt yaparsanız o zaman dediğiniz olur.

 

[ThEeNCi]

aynı ord no alt alta olacak demiştim yeni kayıt da aynı ord ile 6 7 ye kadar ord olabilir ayrı bir macro yapabilirmiyiz kapalı dosyadan veriyi getirdiği gibi tam tersi açık dosyadan kapalı dosyaya veri götürmesi ve kapalı dosyada boş satıra eklesin yerterli güncelleme içine koymayalım lütfen

 

[asi_kral]

aynı ord no alt alta olacak demiştim yeni kayıt da aynı ord ile 6 7 ye kadar ord olabilir ayrı bir macro yapabilirmiyiz kapalı dosyadan veriyi getirdiği gibi tam tersi açık dosyadan kapalı dosyaya veri götürmesi ve kapalı dosyada boş satıra eklesin yerterli güncelleme içine koymayalım lütfen

Merhaba
Module deki kodu bununla değiştirip deneyin.

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, "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
Next: Next
KTP.Save
KTP.Close
Application.ScreenUpdating = True
End Sub
Sub ykayit()
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
S1.Cells(STR, "A") = STR - 6
SAY = S2.Range("A" & Rows.Count).End(xlUp).Row + 1
For STN = 1 To S1.Cells(6, Columns.Count).End(xlToLeft).Column
S2.Cells(SAY, STN) = S1.Cells(STR, STN)
Next: Next
KTP.Save
KTP.Close
Application.ScreenUpdating = True
End Sub

Dosyanız ekte.

 

[ThEeNCi]

Bu sefer tamamdır. Tekrar tekrar çok teşekkür ediyorum.

 

[asi_kral]

Bu sefer tamamdır. Tekrar tekrar çok teşekkür ediyorum.

Kolay Gelsin.