BAŞKA TABLODAN VERİ ALMA HK

A

archers70

Altın Üye
Katılım
19 Eylül 2009
Mesajlar
148
Excel Vers. ve Dili
office 365 ing
Merhaba ; şöyle bir sorum olacak, bir excel veri tablom var , kod - isim - vkn vs bunların sorumlu olduğu kişiler var kişiye göre renklendirilmiş. bu sabit bir dosya. birde her gün yaptığım bir tablo var ve pivotlanıyor hergün. isteğim şu her gün yaptığım pivotta bu kodlar ana dosyadaki veriler içeriğine göre renklendirlilebilir mi?
 
Merhaba,

Foruma dosya eklemek için 2 alternatifiniz var.

Altın üye olmak (ücretli)
Harici dosya paylaşım siteleri (kısmen ücretsiz)
 
Altın üyeliğiniz aktif olmuş. Dosya paylaşımı yapabilirsiniz.
 
Dosyalar farklı dosyalar olduğu için makro kullanmanız daha uygun olacaktır.

İki dosyanız açıkken aşağıdaki kodu çalıştırıp kullanabilirsiniz.

Sayfa ve dosya isimlerini tanımlamanız yeterli olacaktır.

Kodu TEST1 isimli dosyada tutmalısınız. Dosyayı Makro İçerebilen Çalışma Kitabı olarak kayıt edip (TEST1.xlsm) sürekli kullanabilirsiniz.


C++: 
Option Explicit

Sub RenkleriAktar()
    Dim wbKaynak As Workbook
    Dim wbHedef As Workbook
    Dim wsKaynak As Worksheet
    Dim wsHedef As Worksheet
    Dim SonSatirKaynak As Long
    Dim SonSatirHedef As Long
    Dim Dict As Object
    Dim i As Long
    Dim Kod As String
    Dim Renk As Long

    Set wbKaynak = Workbooks("TEST1.xlsm")
    Set wbHedef = Workbooks("TEST2.xlsx")

    Set wsKaynak = wbKaynak.Worksheets("SABİT")
    Set wsHedef = wbHedef.Worksheets("PVT")

    Set Dict = CreateObject("Scripting.Dictionary")

    SonSatirKaynak = wsKaynak.Cells(wsKaynak.Rows.Count, "A").End(xlUp).Row

    ' Kod-Renk eşleşmelerini yükle
    For i = 2 To SonSatirKaynak
        Kod = Trim(CStr(wsKaynak.Cells(i, "B").Value))
        If Len(Kod) > 0 Then
            Dict(Kod) = wsKaynak.Cells(i, "B").Interior.Color
        End If
    Next i

    SonSatirHedef = wsHedef.Cells(wsHedef.Rows.Count, "A").End(xlUp).Row

    ' Eski renkleri temizle
    wsHedef.Range("A:C").Interior.Pattern = xlNone

    ' Yeni renkleri uygula
    For i = 2 To SonSatirHedef
        Kod = Trim(CStr(wsHedef.Cells(i, "A").Value))
        If Dict.Exists(Kod) Then
            Renk = Dict(Kod)
            wsHedef.Range("A" & i & ":C" & i).Interior.Color = Renk
        End If
    Next i

    MsgBox "Renklendirme tamamlandı.", vbInformation
End Sub
 
MERHABA ;
denedim ama olmadı sanırım, şöyle sorayım test1 tablosundaki a sutunu mu baz alınıyor b sütünu mu? yani 11 başlayan kod mu ? m ile başlayan ad mı?
birde her gün test 2 tablosu yenileniyor dolayısı ile kod alnında o alanı değiştirmem gerekli. oraya bir müdahale olur mu? mesela beni yeni yaptığım tablo 05.10 sabah ,06.10 sabah vs gibi adlandırılıyor. orayı dinamik yapabilir miyiz?
 
Merhaba,

Değişken hedef dosya için dosya seçerek işlem yapabilirsiniz.

Eşleştirmede SABİT sayfasının B sütunu ile PVT sayfasının A sütunu kullanılmaktadır.

C++: 
Option Explicit

Sub DosyaSecVeRenklendir()
    Dim wsKaynak As Worksheet
    Dim wsHedef As Worksheet
    Dim wbKaynak As Workbook
    Dim wbHedef As Workbook
    Dim fd As FileDialog
    Dim DosyaYolu As String
    Dim Dict As Object
    Dim SonSatirKaynak As Long
    Dim SonSatirHedef As Long
    Dim i As Long
    Dim Kod As String

    Set wbKaynak = ThisWorkbook
    Set wsKaynak = wbKaynak.Worksheets("SABİT")

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    With fd
        .Title = "Renklendirilecek PİVOT Dosyasını Seçiniz..."
        .Filters.Clear
        .Filters.Add "Excel Dosyaları", "*.xlsx;*.xlsm"

        If .Show <> -1 Then Exit Sub

        DosyaYolu = .SelectedItems(1)
    End With

    Set wbHedef = Workbooks.Open(DosyaYolu)
    Set wsHedef = wbHedef.Worksheets("PVT")

    Set Dict = CreateObject("Scripting.Dictionary")

    SonSatirKaynak = wsKaynak.Cells(wsKaynak.Rows.Count, "A").End(xlUp).Row

    For i = 2 To SonSatirKaynak
        Kod = Trim(CStr(wsKaynak.Cells(i, "A").Value))

        If Kod <> "" Then
            Dict(Kod) = wsKaynak.Cells(i, "A").Interior.Color
        End If
    Next i

    SonSatirHedef = wsHedef.Cells(wsHedef.Rows.Count, "A").End(xlUp).Row

    For i = 2 To SonSatirHedef
        Kod = Trim(CStr(wsHedef.Cells(i, "A").Value))

        If Dict.Exists(Kod) Then
            wsHedef.Range("A" & i & ":C" & i).Interior.Color = Dict(Kod)
        End If
    Next i

    MsgBox "Renklendirme tamamlandı.", vbInformation
End Sub
 
merhaba ; seçim ekranı geldi evet , ama renklendirme olmadı. test2 ekranında renklendirme tamam demesine rağmen..
 
Sayfa ismi PVT olmalı buna dikkat etmeniz gerekiyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst