Çözüldü aynı excelde farklı sayfalardan veri almak.

bycakir

bycakir

Katılım
1 Aralık 2017
Mesajlar
222
Excel Vers. ve Dili
Microsoft Office 365 ProPlus
Altın Üyelik Bitiş Tarihi
18-01-2025
merhabalar;

elimde 5 sayfalı bir excell var ve bu 5 sayfanın içerik mantıgı aynı sadece ürün kodları farklı elimde aşağıda verdiğim gibi bir kod var. fakar bu kod sadece 1 sayfadan veri alıyor ben aşağıda sayfa isimleri verdiğim butun sayfalardan verileri ceksin ve koddaki şekilde sıralasın istiyorum. yardımlarınızı beklemekteyiz.

SAYFA İSİMLERİ = "DÖVME" - "MAKAS BASKI" - "SALINCAK" - "BURÇ"

elimdeki kod sadece kosullar sağlandıgında dövme den veri alıyor. ben kosullar sağlandıgında yukarıdaki 4 sayfadanda veri alsın istiyorum.

Kod: 
Sub aktar()

Application.ScreenUpdating = False
Workbooks.Open Filename:=ActiveWorkbook.Path & "\aylık program.xlsx"
Set s1 = Worksheets("DÖVME")
Set s2 = ThisWorkbook.Worksheets("HEDEF")
s2.Range("A1:F" & Range("A100000").End(3).Row).Clear
s2.Range("A1").Value = "PARÇA KODU"
s2.Range("B1").Value = "İFS MALZ. NO."
s2.Range("C1").Value = "PARÇANIN ADI"
s2.Range("D1").Value = "G.TARİHİ"
s2.Range("E1").Value = "TASHİH"
s2.Range("F1").Value = "B.TARİH"
s2.Range("G1").Value = "İŞ MERKEZİ"
For x = 3 To s1.Range("A100000").End(3).Row
If s1.Cells(x, "M") = Empty Then
son = s2.Range("A100000").End(3).Row + 1
s2.Cells(son, "A") = s1.Cells(x, "B")
s2.Cells(son, "B") = s1.Cells(x, "C")
s2.Cells(son, "C") = s1.Cells(x, "D")
s2.Cells(son, "D") = Format(s1.Cells(x, "K"), "dd/mm/yyyy")
s2.Cells(son, "E") = s1.Cells(x, "L")
s2.Cells(son, "G") = s1.Cells(x, "E")
End If
Next x
ActiveWindow.Close
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömür ÇAKIR ::.."
End Sub
 
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,653
Excel Vers. ve Dili
Pro Plus 2021
Örnek dosyalar olmadığı için denenmemiştir, inşallah çalışır.
Kod: 
Sub aktar()

    Application.ScreenUpdating = False
    Workbooks.Open Filename:=ActiveWorkbook.Path & "\aylık program.xlsx"

    Set s2 = ThisWorkbook.Worksheets("HEDEF")
    s2.Range("A1:F" & Range("A100000").End(3).Row).Clear
    s2.Range("A1").Value = "PARÇA KODU"
    s2.Range("B1").Value = "İFS MALZ. NO."
    s2.Range("C1").Value = "PARÇANIN ADI"
    s2.Range("D1").Value = "G.TARİHİ"
    s2.Range("E1").Value = "TASHİH"
    s2.Range("F1").Value = "B.TARİH"
    s2.Range("G1").Value = "İŞ MERKEZİ"

    son = s2.Range("A100000").End(3).Row 
   
    For Each s1 In Sheets(Array("DÖVME", "MAKAS BASKI", "SALINCAK", "BURÇ"))
        For x = 3 To s1.Range("A100000").End(3).Row
            If s1.Cells(x, "M") = Empty Then
                son = son + 1
                s2.Cells(son, "A") = s1.Cells(x, "B")
                s2.Cells(son, "B") = s1.Cells(x, "C")
                s2.Cells(son, "C") = s1.Cells(x, "D")
                s2.Cells(son, "D") = Format(s1.Cells(x, "K"), "dd/mm/yyyy")
                s2.Cells(son, "E") = s1.Cells(x, "L")
                s2.Cells(son, "G") = s1.Cells(x, "E")
            End If
        Next x
    Next s1

    ActiveWindow.Close
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömür ÇAKIR ::.."
End Sub
 
tugkan

tugkan

Altın Üye
Katılım
6 Kasım 2004
Mesajlar
481
Excel Vers. ve Dili
Excel 2016
Türkçe 64 BIT
Altın Üyelik Bitiş Tarihi
16-10-2025
Merhaba,

Aşağıdaki kodu dener misiniz?
Düz mantıkla diğer kodları çoğaltıp ilk koddan sonra çalışacak şekilde ayarladım ama belki kodu kısaltacak kadar makrodan anlayan arkadaşlar daha pratik çözüm sunabilir.
(inşallah çalışır :rolleyes: )

Kod: 
Sub aktar()

Application.ScreenUpdating = False
Workbooks.Open Filename:=ActiveWorkbook.Path & "\aylık program.xlsx"
Set s1 = Worksheets("DÖVME")
Set s2 = ThisWorkbook.Worksheets("HEDEF")
s2.Range("A1:F" & Range("A100000").End(3).Row).Clear
s2.Range("A1").Value = "PARÇA KODU"
s2.Range("B1").Value = "İFS MALZ. NO."
s2.Range("C1").Value = "PARÇANIN ADI"
s2.Range("D1").Value = "G.TARİHİ"
s2.Range("E1").Value = "TASHİH"
s2.Range("F1").Value = "B.TARİH"
s2.Range("G1").Value = "İŞ MERKEZİ"
For x = 3 To s1.Range("A100000").End(3).Row
If s1.Cells(x, "M") = Empty Then
son = s2.Range("A100000").End(3).Row + 1
s2.Cells(son, "A") = s1.Cells(x, "B")
s2.Cells(son, "B") = s1.Cells(x, "C")
s2.Cells(son, "C") = s1.Cells(x, "D")
s2.Cells(son, "D") = Format(s1.Cells(x, "K"), "dd/mm/yyyy")
s2.Cells(son, "E") = s1.Cells(x, "L")
s2.Cells(son, "G") = s1.Cells(x, "E")
End If
Next x
ActiveWindow.Close

CALL aktar1
CALL aktar2
CALL aktar3

Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömür ÇAKIR ::.."
End Sub

Sub aktar1()

Application.ScreenUpdating = False
Workbooks.Open Filename:=ActiveWorkbook.Path & "\aylık program.xlsx"
Set s1 = Worksheets("MAKAS BASKI")
Set s2 = ThisWorkbook.Worksheets("HEDEF")
s2.Range("A1:F" & Range("A100000").End(3).Row).Clear
s2.Range("A1").Value = "PARÇA KODU"
s2.Range("B1").Value = "İFS MALZ. NO."
s2.Range("C1").Value = "PARÇANIN ADI"
s2.Range("D1").Value = "G.TARİHİ"
s2.Range("E1").Value = "TASHİH"
s2.Range("F1").Value = "B.TARİH"
s2.Range("G1").Value = "İŞ MERKEZİ"
For x = 3 To s1.Range("A100000").End(3).Row
If s1.Cells(x, "M") = Empty Then
son = s2.Range("A100000").End(3).Row + 1
s2.Cells(son, "A") = s1.Cells(x, "B")
s2.Cells(son, "B") = s1.Cells(x, "C")
s2.Cells(son, "C") = s1.Cells(x, "D")
s2.Cells(son, "D") = Format(s1.Cells(x, "K"), "dd/mm/yyyy")
s2.Cells(son, "E") = s1.Cells(x, "L")
s2.Cells(son, "G") = s1.Cells(x, "E")
End If
Next x
ActiveWindow.Close
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömür ÇAKIR ::.."
End Sub

Sub aktar2()

Application.ScreenUpdating = False
Workbooks.Open Filename:=ActiveWorkbook.Path & "\aylık program.xlsx"
Set s1 = Worksheets("SALINCAK")
Set s2 = ThisWorkbook.Worksheets("HEDEF")
s2.Range("A1:F" & Range("A100000").End(3).Row).Clear
s2.Range("A1").Value = "PARÇA KODU"
s2.Range("B1").Value = "İFS MALZ. NO."
s2.Range("C1").Value = "PARÇANIN ADI"
s2.Range("D1").Value = "G.TARİHİ"
s2.Range("E1").Value = "TASHİH"
s2.Range("F1").Value = "B.TARİH"
s2.Range("G1").Value = "İŞ MERKEZİ"
For x = 3 To s1.Range("A100000").End(3).Row
If s1.Cells(x, "M") = Empty Then
son = s2.Range("A100000").End(3).Row + 1
s2.Cells(son, "A") = s1.Cells(x, "B")
s2.Cells(son, "B") = s1.Cells(x, "C")
s2.Cells(son, "C") = s1.Cells(x, "D")
s2.Cells(son, "D") = Format(s1.Cells(x, "K"), "dd/mm/yyyy")
s2.Cells(son, "E") = s1.Cells(x, "L")
s2.Cells(son, "G") = s1.Cells(x, "E")
End If
Next x
ActiveWindow.Close
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömür ÇAKIR ::.."
End Sub

Sub aktar3()

Application.ScreenUpdating = False
Workbooks.Open Filename:=ActiveWorkbook.Path & "\aylık program.xlsx"
Set s1 = Worksheets("BURÇ")
Set s2 = ThisWorkbook.Worksheets("HEDEF")
s2.Range("A1:F" & Range("A100000").End(3).Row).Clear
s2.Range("A1").Value = "PARÇA KODU"
s2.Range("B1").Value = "İFS MALZ. NO."
s2.Range("C1").Value = "PARÇANIN ADI"
s2.Range("D1").Value = "G.TARİHİ"
s2.Range("E1").Value = "TASHİH"
s2.Range("F1").Value = "B.TARİH"
s2.Range("G1").Value = "İŞ MERKEZİ"
For x = 3 To s1.Range("A100000").End(3).Row
If s1.Cells(x, "M") = Empty Then
son = s2.Range("A100000").End(3).Row + 1
s2.Cells(son, "A") = s1.Cells(x, "B")
s2.Cells(son, "B") = s1.Cells(x, "C")
s2.Cells(son, "C") = s1.Cells(x, "D")
s2.Cells(son, "D") = Format(s1.Cells(x, "K"), "dd/mm/yyyy")
s2.Cells(son, "E") = s1.Cells(x, "L")
s2.Cells(son, "G") = s1.Cells(x, "E")
End If
Next x
ActiveWindow.Close
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömür ÇAKIR ::.."
End Sub
 
Y

yanginci34

Altın Üye
Katılım
6 Temmuz 2010
Mesajlar
1,658
Excel Vers. ve Dili
excel2016
Altın Üyelik Bitiş Tarihi
12-10-2026
Denermisiniz
Sub aktar()
Dim s2
Dim x
Dim i
Application.ScreenUpdating = False
Workbooks.Open Filename:=ActiveWorkbook.Path & "\aylık program.xlsx"
Set s2 = ThisWorkbook.Worksheets("HEDEF")
s2.Range("A1:F" & Range("A100000").End(3).Row).Clear
s2.Range("A1").Value = "PARÇA KODU"
s2.Range("B1").Value = "İFS MALZ. NO."
s2.Range("C1").Value = "PARÇANIN ADI"
s2.Range("D1").Value = "G.TARİHİ"
s2.Range("E1").Value = "TASHİH"
s2.Range("F1").Value = "B.TARİH"
s2.Range("G1").Value = "İŞ MERKEZİ"
For i = 1 To Worksheets.Count
For x = 3 To Worksheets(i).Range("A100000").End(3).Row
If Worksheets(i).Cells(x, "M") = Empty Then
son = s2.Range("A100000").End(3).Row + 1
s2.Cells(son, "A") = Worksheets(i).Cells(x, "B")
s2.Cells(son, "B") = Worksheets(i).Cells(x, "C")
s2.Cells(son, "C") = Worksheets(i).Cells(x, "D")
s2.Cells(son, "D") = Format(Worksheets(i).Cells(x, "K"), "dd/mm/yyyy")
s2.Cells(son, "E") = Worksheets(i).Cells(x, "L")
s2.Cells(son, "G") = Worksheets(i).Cells(x, "E")
End If
Next x
Next i
ActiveWindow.Close
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömür ÇAKIR ::.."
End Sub
 
Son düzenleme:
bycakir

bycakir

Katılım
1 Aralık 2017
Mesajlar
222
Excel Vers. ve Dili
Microsoft Office 365 ProPlus
Altın Üyelik Bitiş Tarihi
18-01-2025
hepinizin eline sağlık 3 ü de çalıştı

yalnız sürekli üzerine ekliyor ben a han g de dahil temizlesin yeni veri çeksin istiyorum.
en sade bu kod geldi bana bunu uygulayacam fakat dediğim gibi önce temizlesin istiyorum ilgili satırı.

Kod: 
Sub plana_aktar()

    Application.ScreenUpdating = False
    Workbooks.Open Filename:=ActiveWorkbook.Path & "\aylık program.xlsx"

    Set s2 = ThisWorkbook.Worksheets("HEDEF")
    s2.Range("A1:F" & Range("A100000").End(3).Row).Clear
    s2.Range("A1").Value = "PARÇA KODU"
    s2.Range("B1").Value = "İFS MALZ. NO."
    s2.Range("C1").Value = "PARÇANIN ADI"
    s2.Range("D1").Value = "G.TARİHİ"
    s2.Range("E1").Value = "TASHİH"
    s2.Range("F1").Value = "B.TARİH"
    s2.Range("G1").Value = "İŞ MERKEZİ"
    s2.Range("H1").Value = "TAHMİNİ SÜRE saat"

    son = s2.Range("A100000").End(3).Row
  
    For Each s1 In Sheets(Array("DÖVME", "MAKAS BASKI", "SALINCAK", "BURÇ"))
        For x = 2 To s1.Range("A100000").End(3).Row
            If s1.Cells(x, "M") = Empty Then
                son = son + 1
                s2.Cells(son, "A") = s1.Cells(x, "B")
                s2.Cells(son, "B") = s1.Cells(x, "C")
                s2.Cells(son, "C") = s1.Cells(x, "D")
                s2.Cells(son, "D") = Format(s1.Cells(x, "K"), "dd/mm/yyyy")
                s2.Cells(son, "E") = s1.Cells(x, "L")
                s2.Cells(son, "G") = s1.Cells(x, "E")
                s2.Cells(son, "H") = s1.Cells(x, "I")
            End If
        Next x
    Next s1

    ActiveWindow.Close
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömür ÇAKIR ::.."
End Sub
 
Son düzenleme:
Y

yanginci34

Altın Üye
Katılım
6 Temmuz 2010
Mesajlar
1,658
Excel Vers. ve Dili
excel2016
Altın Üyelik Bitiş Tarihi
12-10-2026
Buyrun
Sub plana_aktar()

Application.ScreenUpdating = False
Set s2 = ThisWorkbook.Worksheets("HEDEF")
s2.Range("A1:g" & Range("A100000").End(3).Row).ClearContents
Workbooks.Open Filename:=ActiveWorkbook.Path & "\aylık program.xlsx"
s2.Range("A1").Value = "PARÇA KODU"
s2.Range("B1").Value = "İFS MALZ. NO."
s2.Range("C1").Value = "PARÇANIN ADI"
s2.Range("D1").Value = "G.TARİHİ"
s2.Range("E1").Value = "TASHİH"
s2.Range("F1").Value = "B.TARİH"
s2.Range("G1").Value = "İŞ MERKEZİ"
s2.Range("H1").Value = "TAHMİNİ SÜRE saat"

son = s2.Range("A100000").End(3).Row

For Each s1 In Sheets(Array("DÖVME", "MAKAS BASKI", "SALINCAK", "BURÇ"))
For x = 2 To s1.Range("A100000").End(3).Row
If s1.Cells(x, "M") = Empty Then
son = son + 1
s2.Cells(son, "A") = s1.Cells(x, "B")
s2.Cells(son, "B") = s1.Cells(x, "C")
s2.Cells(son, "C") = s1.Cells(x, "D")
s2.Cells(son, "D") = Format(s1.Cells(x, "K"), "dd/mm/yyyy")
s2.Cells(son, "E") = s1.Cells(x, "L")
s2.Cells(son, "G") = s1.Cells(x, "E")
s2.Cells(son, "H") = s1.Cells(x, "I")
End If
Next x
Next s1

ActiveWindow.Close
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömür ÇAKIR ::.."
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst