Soru Kapalı Dosyadan Veri Aktarımı Hakkında2..

Katılım
8 Aralık 2011
Mesajlar
745
Beğeniler
17
Excel Vers. ve Dili
Excel 2016,32bit
#1
Merhabalar;

Öncelikle daha önce burada benzer bir konu açmış ve Sayın Zeki Gürsoy'un yardımı ile sonuca ulaşmıştım.Gayet başarılı şekilde devam ederken verilerim ve parametrelerim çoğaldıkça yeni düzenlemelere ihtiyacım olduğumdan tekrar benzer bir konu açmak durumunda kaldım:-(
Daha önce açmış olduğum konu başlığını "çözüldü" olarak değiştirdiğim için revize edemedim. O yüzden yeni bir konu başlığı açma ihtiyacı duydum. Benzer bir konunun tekrar açılmaması gerekirdi o yüzden forum yöneticilerinden bu konuda özür dilerim.:(

Sorunuma gelecek olur isem şöyle ki;
"açık" ve "kapalı" olmak üzere iki adet çalışma dosyam mevcut.

"kapalı" dosyadaki "ham veriler" sayfasında ; 4.satırda bulunan , "E:H:K:N:Q:T:W:Z:AC:AF:AI:AL" sütunlarındaki verileri,

"açık" dosyadaki "sonuçlar" sayfasındaki ; "D" sütununa aktarmak istiyorum. ("D4" ten itibaren olacak)


Not:
* "kapalı" dosyadaki "ham veriler" sayfasında bulunan veriler de formül olacak aktarılırken sorun yaratmaması adına bilgilendirmek isterim.
** "kapalı" dosyadaki "ham veriler" sayfasında 4.satırdan 250.satıra kadar veriler bulunmakta, haliyle işlemler aynı mantık ile tüm verileri aktarmalı.
 

Ekli dosyalar

Ziynettin

Altın Üye
Katılım
18 Nisan 2008
Mesajlar
726
Beğeniler
124
Excel Vers. ve Dili
office2010
#2
Merhaba,

Açık ve Kapalı dosyalar aynı klasörde olmalı.

Kod:
Sub test()
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\"
dosya = "kapalı.xlsx"
GetObject (yol & dosya)
Set d = CreateObject("scripting.dictionary")
sayfa = "HAM VERİLER"
Set s1 = Workbooks(dosya).Worksheets(sayfa)
son = s1.Cells(Rows.Count, 2).End(3).Row
a = s1.Range("B2:AL" & son).Value
Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
    For i = 3 To UBound(a)
        For j = 3 To UBound(a, 2)
        If a(1, j) <> "" Then
            krt = a(i, 1) & "|" & a(i, 2) & "|" & a(1, j)
            d(krt) = a(i, j + 1)
        End If
        Next j
    Next i
Set sc = Sheets("sonuclar")
son = sc.Cells(Rows.Count, 2).End(3).Row
b = sc.Range("B3:J" & son).Value
sat = UBound(b)
sut = UBound(b, 2)
ReDim c(1 To sat - 1, 1 To sut - 2)
    For i = 2 To sat
        For j = 3 To sut
            krt = b(i, 1) & "|" & b(1, j) & "|" & b(i, 2)
            c(i - 1, j - 2) = d(krt)
        Next j
    Next i
sc.[D4].Resize(sat - 1, sut - 2) = c
Workbooks(dosya).Close
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub
 
Katılım
8 Aralık 2011
Mesajlar
745
Beğeniler
17
Excel Vers. ve Dili
Excel 2016,32bit
#3
Sayın Ziynettin, ilginize çok teşekkür ederim. Ellerinize sağlık, tam istediğim şekilde oldu.(y):giggle:
 
Katılım
8 Aralık 2011
Mesajlar
745
Beğeniler
17
Excel Vers. ve Dili
Excel 2016,32bit
#4
Merhabalar,
1 nolu mesajımda belirttiğim soruma sayın Ziynettin 2 nolu mesajıyla çok güzel çözüm getirdi ve sorunsuz kullanmaktayım. Lakin 1 nolu mesajımda bulunan;
"kapalı" dosyadaki "ham veriler" sayfasında ; 4.satırda bulunan , "E:H:K:N:Q:T:W:Z:AC:AF:AI:AL" sütunlarındaki verilerin yerine ,

Şu verileri almak istemekteyim ;

"kapalı" dosyadaki "ham veriler" sayfasında ; 4.satırda bulunan , "F:I:L:O:R:U:X:AA:AD:AG:AJ:AM" sütunlarındaki verilerin , yine aynı şekilde

"açık" dosyadaki "sonuçlar" sayfasındaki ; "D" sütununa aktarmak istiyorum. ("D4" ten itibaren olacak)

Sayın Ziynettin'in 2 nolu mesajındaki kodlarda yapmaya çalıştım ama yapamadım. :-( Kodlar üzerinde nasıl bir değişiklik ile yapılabilir?

Ekte "kapalı" dosyadaki kırmızı renkli verileri almamda sıkıntı olmuyor hali hazırdaki kodlar ile, lakin sarı renkli sütunlardaki verileri aynı şekilde almak istiyorum.:giggle:
 

Ekli dosyalar

Ziynettin

Altın Üye
Katılım
18 Nisan 2008
Mesajlar
726
Beğeniler
124
Excel Vers. ve Dili
office2010
#5
Kod:
Sub test1()
Z = TimeValue(Now)
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\"
dosya = "kapalı.xlsx"
GetObject (yol & dosya)
Set d = CreateObject("scripting.dictionary")
sayfa = "HAM VERİLER"
Set s1 = Workbooks(dosya).Worksheets(sayfa)
son = s1.Cells(Rows.Count, 2).End(3).Row
a = s1.Range("B2:AM" & son).Value
sutun = Array("", 3, 6, 9, 12, 15, 18, 21, 24, 27, 30, 33, 36)
Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
    For i = 3 To UBound(a)
        For j = 1 To UBound(sutun)
            krt = a(i, 1) & "|" & a(i, 2) & "|" & a(1, sutun(j))
            d(krt) = a(i, sutun(j) + 2)
        Next j
    Next i
Set sc = Sheets("sonuclar")
son = sc.Cells(Rows.Count, 2).End(3).Row
b = sc.Range("B3:J" & son).Value
sat = UBound(b)
sut = UBound(b, 2)
ReDim c(1 To sat - 1, 1 To sut - 2)
    For i = 2 To sat
        For j = 3 To sut
            krt = b(i, 1) & "|" & b(1, j) & "|" & b(i, 2)
            c(i - 1, j - 2) = d(krt)
        Next j
    Next i
sc.[D4].Resize(sat - 1, sut - 2) = c
Workbooks(dosya).Close
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub
 
Katılım
8 Aralık 2011
Mesajlar
745
Beğeniler
17
Excel Vers. ve Dili
Excel 2016,32bit
#6
Sayın Ziynettin, ilginize çok teşekkür ederim.Ellerinize sağlık istediğim şekilde oldu.(y):giggle::giggle:
 
Üst