• DİKKAT

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

Soru Mevcut Kodda Ekstra İki Veriyi Daha Getirme

T

TURKOLOG

Altın Üye
Katılım
13 Kasım 2008
Mesajlar
745
Excel Vers. ve Dili
2016 64 TR
Merhaba arkadaşlar aşağıdaki kod çalışıyor.
Set dic = CreateObject("Scripting.Dictionary") Set s1 = ThisWorkbook.Sheets("VERİ") Set s2 = ThisWorkbook.Sheets("KONTROL") Set s3 = ThisWorkbook.Sheets(Me.ComboBox1.Value) son = s1.Cells(Rows.Count, 1).End(3).Row soncomboSayfa = s3.Cells(Rows.Count, "B").End(3).Row sonKontrolSicil = s2.Cells(Rows.Count, "F").End(3).Row
Ve
VERİ sayfasından A,B,C,D ve E sütunlarını kopyalayıp ComboBox1deki sayafaya A7'den itibaren getiriyor .
VERİ sayfasından F sütununu kopyalayıp ComboBox1'deki sayfaya AK7'den itibaren getiriyor .

Buraya kadar kod çalışıyor

Benim yapamadığım ve olmasını istediğim
Bu çalışan kodlara ilaveten
Aynı yöntemle
VERİ sayfasından AL sütununu kopyalayıp ComboBox1'deki sayfaya AL7'den itibaren getirmesi
VERİ sayfasından AM sütununu kopyalayıp ComboBox1'deki sayfaya AM7'den itibaren getirmesi

Yardımcı olabilecek olan varsa çok sevinirim.





Kod: 
Private Sub SayfayıHazırla_Click()

    Dim bul As Range, s1 As Worksheet, s2 As Worksheet, s3 As Worksheet, dic As Object
    Dim arr(), i As Long, son As Long, dogru As Boolean, say As Long, soncomboSayfa As Long
    Dim sonKontrolSicil As Long, varmi As Boolean, veri1, aranan As Long, arr2()
    Dim Mail1 As Long, Mail2 As Long
   
    varmi = True
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    If Len(Trim(Me.ComboBox1.Value)) = 0 Then
        MsgBox "Sayfa seciniz...", vbCritical, "Sayfa Seçiniz"
        GoTo son
    End If
   
    Set dic = CreateObject("Scripting.Dictionary")
    Set s1 = ThisWorkbook.Sheets("VERİ")
    Set s2 = ThisWorkbook.Sheets("KONTROL")
    Set s3 = ThisWorkbook.Sheets(Me.ComboBox1.Value)
    son = s1.Cells(Rows.Count, 1).End(3).Row
    soncomboSayfa = s3.Cells(Rows.Count, "B").End(3).Row
    sonKontrolSicil = s2.Cells(Rows.Count, "F").End(3).Row

   
    If soncomboSayfa < 7 Then soncomboSayfa = 7
    If son < 2 Then GoTo son
   
    veri1 = s1.Range("A2:AZ" & son).Value
   
    If sonKontrolSicil < 2 Then
        varmi = False
        GoTo var
    End If
   
    For i = 2 To sonKontrolSicil
        aranan = s2.Cells(i, "F").Value + 0
        If aranan > 0 Then
            If Not dic.exists(saranan) Then dic.Add aranan, aranan
        End If
    Next
   
 
var:
    ReDim arr(1 To son, 1 To 5)
    ReDim arr2(1 To son, 1 To 1)
    say = 1
    On Error Resume Next
    With s3.Range("A7:AK" & Rows.Count)
        .Clear
        .UnMerge
        .ClearContents
        .Interior.ColorIndex = xlNone
        .Borders.LineStyle = xlNone
    End With
    On Error GoTo 0
    For i = LBound(veri1) To UBound(veri1)
        dogru = False
        If varmi = True Then
            If veri1(i, 2) + 0 = dic(veri1(i, 2) + 0) Then
                dogru = True
                GoTo 10
            End If
        End If
       
        Set bul = s2.Range("E:E").Find(veri1(i, 5), , , 1)
        If Not bul Is Nothing Then dogru = True
        Set bul = s2.Range("D:D").Find(veri1(i, 6), , , 1)
        If Not bul Is Nothing Then dogru = True
10
        If dogru = False Then
            arr(say, 1) = say
            arr(say, 2) = veri1(i, 2) + 0
            arr(say, 3) = veri1(i, 5)
            arr(say, 4) = veri1(i, 3)
            arr(say, 5) = veri1(i, 4)
            arr2(say, 1) = veri1(i, 6)
            say = say + 1
        End If
    Next
    If say > 1 Then
        s3.Range("A7").Resize(say, UBound(arr, 2)).Value = arr
        s3.Range("AK7").Resize(say, 1).Value = arr2
        soncomboSayfa = s3.Cells(Rows.Count, "AK").End(3).Row
        aciklamalar s3, soncomboSayfa
       imzalar s3, soncomboSayfa, aciklama, s2
    End If
   
son:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    On Error Resume Next
    Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing
    Erase veri1: Set bul = Nothing: Erase arr: Set dic = Nothing: Erase arr2
    MsgBox "Bitti", vbInformation, "Bitti"

End Sub
 
Deneyiniz.

C++: 
Option Explicit

Sub Aktar()
    Dim Son As Long
    Son = Sheets("VERİ").Cells(Rows.Count, "AL").End(3).Row
    With Sheets(CStr(Sheets("VERİ").OLEObjects("ComboBox1").Object.Value))
        .Range("AL7").Resize(Rows.Count - 6, 2).ClearContents
        .Range("AL7").Resize(Son - 1, 2).Value = Sheets("VERİ").Range("AL2:AM" & Son).Value
    End With
End Sub
 
Örnek dosya paylaşırsanız ne yapmak istediğinizi daha net anlayabiliriz. Böyle havanda su dövüp duruyoruz.
 
Deneyiniz.

C++: 
Private Sub SayfayıHazırla_Click()
    Dim bul As Range, s1 As Worksheet, s2 As Worksheet, s3 As Worksheet, dic As Object
    Dim arr(), i As Long, son As Long, dogru As Boolean, say As Long, soncomboSayfa As Long
    Dim sonKontrolSicil As Long, varmi As Boolean, veri1, aranan As Long, arr2()
    Dim Mail1 As Long, Mail2 As Long
   
    varmi = True
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    If Len(Trim(Me.ComboBox1.Value)) = 0 Then
        MsgBox "Sayfa seciniz...", vbCritical, "Sayfa Seçiniz"
        GoTo son
    End If
   
    Set dic = CreateObject("Scripting.Dictionary")
    Set s1 = ThisWorkbook.Sheets("VERİ")
    Set s2 = ThisWorkbook.Sheets("KONTROL")
    Set s3 = ThisWorkbook.Sheets(Me.ComboBox1.Value)
    son = s1.Cells(Rows.Count, 1).End(3).Row
    soncomboSayfa = s3.Cells(Rows.Count, "B").End(3).Row
    sonKontrolSicil = s2.Cells(Rows.Count, "F").End(3).Row
 
   
    If soncomboSayfa < 7 Then soncomboSayfa = 7
    If son < 2 Then GoTo son
   
    veri1 = s1.Range("A2:AZ" & son).Value
   
    If sonKontrolSicil < 2 Then
        varmi = False
        GoTo var
    End If
   
    For i = 2 To sonKontrolSicil
        aranan = s2.Cells(i, "F").Value + 0
        If aranan > 0 Then
            If Not dic.exists(saranan) Then dic.Add aranan, aranan
        End If
    Next
   
  
var:
    ReDim arr(1 To son, 1 To 5)
    ReDim arr2(1 To son, 1 To 3)
    say = 1
    On Error Resume Next
    With s3.Range("A7:AM" & Rows.Count)
        .Clear
        .UnMerge
        .ClearContents
        .Interior.ColorIndex = xlNone
        .Borders.LineStyle = xlNone
    End With
    On Error GoTo 0
    For i = LBound(veri1) To UBound(veri1)
        dogru = False
        If varmi = True Then
            If veri1(i, 2) + 0 = dic(veri1(i, 2) + 0) Then
                dogru = True
                GoTo 10
            End If
        End If
       
        Set bul = s2.Range("E:E").Find(veri1(i, 5), , , 1)
        If Not bul Is Nothing Then dogru = True
        Set bul = s2.Range("D:D").Find(veri1(i, 6), , , 1)
        If Not bul Is Nothing Then dogru = True
10
        If dogru = False Then
            arr(say, 1) = say
            arr(say, 2) = veri1(i, 2) + 0
            arr(say, 3) = veri1(i, 5)
            arr(say, 4) = veri1(i, 3)
            arr(say, 5) = veri1(i, 4)
            arr2(say, 1) = veri1(i, 6)
            arr2(say, 2) = veri1(i, 38)
            arr2(say, 3) = veri1(i, 39)
            say = say + 1
        End If
    Next
    If say > 1 Then
        s3.Range("A7").Resize(say, UBound(arr, 2)).Value = arr
        s3.Range("AK7").Resize(say, 3).Value = arr2
        soncomboSayfa = s3.Cells(Rows.Count, "AK").End(3).Row
        aciklamalar s3, soncomboSayfa
       imzalar s3, soncomboSayfa, aciklama, s2
    End If
   
son:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    On Error Resume Next
    Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing
    Erase veri1: Set bul = Nothing: Erase arr: Set dic = Nothing: Erase arr2
    MsgBox "Bitti", vbInformation, "Bitti"
End Sub
 
Sayın @Korhan Ayhan Hocam çok teşekkür ederim kod çalıştı. yüreğinize sağlık.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst