• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

bycakir

bycakir

Katılım
1 Aralık 2017
Mesajlar
223
Excel Vers. ve Dili
Microsoft Office 365 ProPlus
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
 
Ö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
 
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
 
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:
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:
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.
Geri
Üst