• DİKKAT

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

Kod Konusunda yardım

M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
BU MAKRO İLE ARKAS İSİMLİ ŞİRKETTE ÇALIŞAN ÇALIŞMA DURUMU ETKİN OLAN A PERSONELERİNİ ANA SAYFAMDAN KONTROL İSİMLİ SAYFAMA GETİRTİYORUM. ANCAK AYNI ŞİRKETTE ÇALIŞAN ÇALIŞMA DURUMU ETKİN B,C,D,E,F PERSONELİNİDE TOPLU OLARAK BU KOD İLE GETİRTMEK İSTİYORUM. ANCAK BİR TÜRLÜ KODUN İÇİNE YERLEŞTİRME YAPAMADIM. YARDIMCI OLURSANıZ SEVİNİRİM

Private Sub OptionButton10_Click()
Dim s1 As Worksheet: Dim s2 As Worksheet: Dim i As Integer
Set s1 = Sheets("ANA SAYFA"): Set s2 = Sheets("KONTROL")
Application.ScreenUpdating = False
'On Error Resume Next
s2.Range("A8:T" & Rows.Count) = ""
a = s1.Range("A2:Y" & s1.Cells(Rows.Count, 2).End(3).Row).Value 'coutt,3 demek tc kimlik numarasýna göre süzüyor
ReDim B(1 To UBound(a), 1 To 25)

For i = 2 To UBound(a) + 1

If s1.Range("X" & i) = "ARKAS" And s1.Range("G" & i) = "A GOREVLISI" And s1.Range("W" & i) = "Etkin" Then
B GOREVLISI
C GOREVLISI
D GOREVLISI
E GOREVLISI
F GOREVLISI

say = say + 1
B(say, 1) = a(i - 1, 1): B(say, 2) = a(i - 1, 2)
B(say, 3) = a(i - 1, 3): B(say, 4) = a(i - 1, 4)
B(say, 5) = a(i - 1, 7): B(say, 6) = a(i - 1, 8)
B(say, 7) = a(i - 1, 9): B(say, 8) = a(i - 1, 12)
B(say, 9) = a(i - 1, 14): B(say, 11) = a(i - 1, 16)
B(say, 12) = a(i - 1, 17): B(say, 13) = a(i - 1, 18)
B(say, 14) = a(i - 1, 19): B(say, 15) = a(i - 1, 20)
B(say, 16) = a(i - 1, 21): B(say, 17) = a(i - 1, 22)
B(say, 18) = a(i - 1, 23): B(say, 19) = a(i - 1, 24)
'b(say, 18) = a(i - 1, 23): b(say, 20) = a(i - 1, 25)
'b(say, 21) = a(i - 1, 21): b(say, 22) = a(i - 1, 22)
'b(say, 23) = a(i - 1, 23): b(say, 24) = a(i - 1, 24)
B(say, 20) = a(i - 1, 25)



End If
Next i
If say > 0 Then
s2.Range("A8").Resize(say, 25) = B
Application.ScreenUpdating = True

MsgBox "LISTE DÜZENLENMISTIR.", vbInformation

Else
MsgBox "LISTELENEÇEK BILGI BULUNAMADI.", vbInformation
End If
'Cells(4, 3) = WorksheetFunction.CountA(Worksheets("KONTROL").Range("C8:C6000"))

'MsgBox "LISTE DÜZENLENMISTIR.", vbInformation
End Sub
 
metin_0606' Alıntı:
BU MAKRO İLE ARKAS İSİMLİ ŞİRKETTE ÇALIŞAN ÇALIŞMA DURUMU ETKİN OLAN A PERSONELERİNİ ANA SAYFAMDAN KONTROL İSİMLİ SAYFAMA GETİRTİYORUM. ANCAK AYNI ŞİRKETTE ÇALIŞAN ÇALIŞMA DURUMU ETKİN B,C,D,E,F PERSONELİNİDE TOPLU OLARAK BU KOD İLE GETİRTMEK İSTİYORUM. ANCAK BİR TÜRLÜ KODUN İÇİNE YERLEŞTİRME YAPAMADIM. YARDIMCI OLURSANıZ SEVİNİRİM

Private Sub OptionButton10_Click()
Dim s1 As Worksheet: Dim s2 As Worksheet: Dim i As Integer
Set s1 = Sheets("ANA SAYFA"): Set s2 = Sheets("KONTROL")
Application.ScreenUpdating = False
'On Error Resume Next
s2.Range("A8:T" & Rows.Count) = ""
a = s1.Range("A2:Y" & s1.Cells(Rows.Count, 2).End(3).Row).Value 'coutt,3 demek tc kimlik numarasýna göre süzüyor
ReDim B(1 To UBound(a), 1 To 25)

For i = 2 To UBound(a) + 1

If s1.Range("X" & i) = "ARKAS" And s1.Range("G" & i) = "A GOREVLISI" And s1.Range("W" & i) = "Etkin" Then
B GOREVLISI
C GOREVLISI
D GOREVLISI
E GOREVLISI
F GOREVLISI

say = say + 1
B(say, 1) = a(i - 1, 1): B(say, 2) = a(i - 1, 2)
B(say, 3) = a(i - 1, 3): B(say, 4) = a(i - 1, 4)
B(say, 5) = a(i - 1, 7): B(say, 6) = a(i - 1, 8)
B(say, 7) = a(i - 1, 9): B(say, 8) = a(i - 1, 12)
B(say, 9) = a(i - 1, 14): B(say, 11) = a(i - 1, 16)
B(say, 12) = a(i - 1, 17): B(say, 13) = a(i - 1, 18)
B(say, 14) = a(i - 1, 19): B(say, 15) = a(i - 1, 20)
B(say, 16) = a(i - 1, 21): B(say, 17) = a(i - 1, 22)
B(say, 18) = a(i - 1, 23): B(say, 19) = a(i - 1, 24)
'b(say, 18) = a(i - 1, 23): b(say, 20) = a(i - 1, 25)
'b(say, 21) = a(i - 1, 21): b(say, 22) = a(i - 1, 22)
'b(say, 23) = a(i - 1, 23): b(say, 24) = a(i - 1, 24)
B(say, 20) = a(i - 1, 25)



End If
Next i
If say > 0 Then
s2.Range("A8").Resize(say, 25) = B
Application.ScreenUpdating = True

MsgBox "LISTE DÜZENLENMISTIR.", vbInformation

Else
MsgBox "LISTELENEÇEK BILGI BULUNAMADI.", vbInformation
End If
'Cells(4, 3) = WorksheetFunction.CountA(Worksheets("KONTROL").Range("C8:C6000"))

'MsgBox "LISTE DÜZENLENMISTIR.", vbInformation
End Sub
Genişletmek için tıkla ...
Dosyayı ekliyorum Necdet Bey buradaki kriterler Çalıştığı şirket "Arkas", Çalışma Durumu "Etkin" Görevi A,B,C,D,E,F Görevlisi olanları ANA SAYFA isimli datada bulup KONTROL isimli sayfanın ilgili sütunlarına listeleyecek. Mevcut makro ile sadece A görevlilerini Kontrol isimli sayfama getirtiyorum ama diğerlerini bir türlü koda entegre edemedim
 

Ekli dosyalar

Ziynettin' Alıntı:
Form üzerinden seçenekli yapılan çalışmayı deneyiniz.
Genişletmek için tıkla ...
Ziynettin hocam öncelikle yardımınız için teşekkür ederim güzel bir çalışma olmuş. Bu veri getirmeyi sadece tek bir combotbutton üzerinden yapamayızmı tek butona basınca hepsi gelsin seçmeli olmasın yani
 
If s1.Range("X" & i) = "ARKAS" And s1.Range("G" & i) = "A GOREVLISI" And s1.Range("W" & i) = "Etkin" Then sizin kod satırındaki kriterlere göre uyarlandı.

Kod: 
Sub deneme()
Application.ScreenUpdating = False
Set sh1 = Sheets("ANA SAYFA")
Set sh2 = Sheets("KONTROL")
a = sh1.Range("A2:Y" & sh1.Cells(Rows.Count, 2).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To 20)
For i = 1 To UBound(a)
    'If s1.Range("X" & i) = "ARKAS" And s1.Range("G" & i) = "A GOREVLISI" And s1.Range("W" & i) = "Etkin" Then
    If a(i, 24) = "ARKAS" And a(i, 7) = "A GÖREVLİSİ" And a(i, 23) = "Etkin" Then
        say = say + 1
        For j = 1 To 4
            b(say, j) = a(i, j)
        Next j
         For j = 1 To 3
            b(say, j + 4) = a(i, j + 6)
        Next j
            b(say, 8) = a(i, 12)
         For j = 1 To 12
            b(say, j + 8) = a(i, j + 13)
        Next j
    End If
Next i
son = sh1.Cells(Rows.Count, 1).End(3).Row
If son > 7 Then
    sh2.Range("A8:T" & son) = Empty
    sh2.Range("A8:T" & son).Borders.LineStyle = xlNone
End If
If say > 0 Then
    sh2.[A8].Resize(say, 20) = b
    sh2.[A8].Resize(say, 20).Borders.LineStyle = 1
End If
End Sub
 
Ziynettin' Alıntı:
If s1.Range("X" & i) = "ARKAS" And s1.Range("G" & i) = "A GOREVLISI" And s1.Range("W" & i) = "Etkin" Then sizin kod satırındaki kriterlere göre uyarlandı.

Kod: 
Sub deneme()
Application.ScreenUpdating = False
Set sh1 = Sheets("ANA SAYFA")
Set sh2 = Sheets("KONTROL")
a = sh1.Range("A2:Y" & sh1.Cells(Rows.Count, 2).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To 20)
For i = 1 To UBound(a)
    'If s1.Range("X" & i) = "ARKAS" And s1.Range("G" & i) = "A GOREVLISI" And s1.Range("W" & i) = "Etkin" Then
    If a(i, 24) = "ARKAS" And a(i, 7) = "A GÖREVLİSİ" And a(i, 23) = "Etkin" Then
        say = say + 1
        For j = 1 To 4
            b(say, j) = a(i, j)
        Next j
         For j = 1 To 3
            b(say, j + 4) = a(i, j + 6)
        Next j
            b(say, 8) = a(i, 12)
         For j = 1 To 12
            b(say, j + 8) = a(i, j + 13)
        Next j
    End If
Next i
son = sh1.Cells(Rows.Count, 1).End(3).Row
If son > 7 Then
    sh2.Range("A8:T" & son) = Empty
    sh2.Range("A8:T" & son).Borders.LineStyle = xlNone
End If
If say > 0 Then
    sh2.[A8].Resize(say, 20) = b
    sh2.[A8].Resize(say, 20).Borders.LineStyle = 1
End If
End Sub
Genişletmek için tıkla ...
Ziynettin' Alıntı:
If s1.Range("X" & i) = "ARKAS" And s1.Range("G" & i) = "A GOREVLISI" And s1.Range("W" & i) = "Etkin" Then sizin kod satırındaki kriterlere göre uyarlandı.

Kod: 
Sub deneme()
Application.ScreenUpdating = False
Set sh1 = Sheets("ANA SAYFA")
Set sh2 = Sheets("KONTROL")
a = sh1.Range("A2:Y" & sh1.Cells(Rows.Count, 2).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To 20)
For i = 1 To UBound(a)
    'If s1.Range("X" & i) = "ARKAS" And s1.Range("G" & i) = "A GOREVLISI" And s1.Range("W" & i) = "Etkin" Then
    If a(i, 24) = "ARKAS" And a(i, 7) = "A GÖREVLİSİ" And a(i, 23) = "Etkin" Then
        say = say + 1
        For j = 1 To 4
            b(say, j) = a(i, j)
        Next j
         For j = 1 To 3
            b(say, j + 4) = a(i, j + 6)
        Next j
            b(say, 8) = a(i, 12)
         For j = 1 To 12
            b(say, j + 8) = a(i, j + 13)
        Next j
    End If
Next i
son = sh1.Cells(Rows.Count, 1).End(3).Row
If son > 7 Then
    sh2.Range("A8:T" & son) = Empty
    sh2.Range("A8:T" & son).Borders.LineStyle = xlNone
End If
If say > 0 Then
    sh2.[A8].Resize(say, 20) = b
    sh2.[A8].Resize(say, 20).Borders.LineStyle = 1
End If
End Sub
Genişletmek için tıkla ...
ziynettin hocam listeye A görevlilerini getiriyor sadece bunun dışında B-C-D-E-F ünvanlarına sahip görevlileride getirtebilirmiyiz
 
yani hepsi
metin_0606' Alıntı:
ziynettin hocam listeye A görevlilerini getiriyor sadece bunun dışında B-C-D-E-F ünvanlarına sahip görevlileride getirtebilirmiyiz
Genişletmek için tıkla ...
Yani Arkasta Etkin olarak çalışan A-B-C-D-E-F Görevlilerini aynı anda getirtemeyizmi
 
If a(i, 24) = "ARKAS" And a(i, 7) = "A GÖREVLİSİ" And a(i, 23) = "Etkin" Then
satrını
If a(i, 24) = "ARKAS" And a(i, 23) = "Etkin" Then
yapın.
 
Merhaba,

Düzenlenmiş dosyanız ektedir.
ayrıca dosyayı indiremeyecekler içinde kodlarda aşağıdaki gibidir.

Kod: 
Private Sub CommandButton1_Click()

Dim SonSatANASAYFA As Long
SonSatANASAYFA = Sheets("ANA SAYFA").Range("A" & Rows.Count).End(xlUp).Row 'A sütununun son dolu satırı

Dim SonSatKONTROL As Long
SonSatKONTROL = Sheets("KONTROL").Range("A" & Rows.Count).End(xlUp).Row 'A sütununun son dolu satırı

Dim GUVENLIKYERI As String
GUVENLIKYERI = UCase(Replace(Replace(Replace(Replace(Replace(Replace(RTrim(Sheets("KONTROL").Cells(1, "B")), "ı", "I"), "i", "İ"), "ş", "Ş"), "ö", "Ö"), "ü", "Ü"), "ğ", "Ğ"))

Dim CALISMADURUMU As String
CALISMADURUMU = Application.Proper(Sheets("KONTROL").Cells(2, "B"))

'***************Kontrol sayfasındaki tablonun başlıklar hariç temizlenmesi************************
    Dim rngb As Range
    Set rngb = Sheets("KONTROL").Range("A8:T" & SonSatKONTROL + 7)
    rngb.ClearContents
   
    With rngb.Borders
        .LineStyle = Excel.XlLineStyle.xlLineStyleNone
   
    End With

'**************************************************************************************************

Dim i As Integer
Dim z As Integer
z = 8

For i = 2 To SonSatANASAYFA

        If Sheets("ANA SAYFA").Cells(i, "X") = GUVENLIKYERI And Sheets("ANA SAYFA").Cells(i, "W") = CALISMADURUMU Then
       
            Sheets("KONTROL").Cells(z, "A") = Sheets("ANA SAYFA").Cells(i, "A")
            Sheets("KONTROL").Cells(z, "B") = Sheets("ANA SAYFA").Cells(i, "B")
            Sheets("KONTROL").Cells(z, "C") = Sheets("ANA SAYFA").Cells(i, "C")
            Sheets("KONTROL").Cells(z, "D") = Sheets("ANA SAYFA").Cells(i, "D")
            Sheets("KONTROL").Cells(z, "E") = Sheets("ANA SAYFA").Cells(i, "G")
            Sheets("KONTROL").Cells(z, "F") = Sheets("ANA SAYFA").Cells(i, "H")
            Sheets("KONTROL").Cells(z, "G") = Sheets("ANA SAYFA").Cells(i, "I")
            Sheets("KONTROL").Cells(z, "H") = Sheets("ANA SAYFA").Cells(i, "L")
            Sheets("KONTROL").Cells(z, "I") = Sheets("ANA SAYFA").Cells(i, "N")
            Sheets("KONTROL").Cells(z, "J") = Sheets("ANA SAYFA").Cells(i, "O")
            Sheets("KONTROL").Cells(z, "K") = Sheets("ANA SAYFA").Cells(i, "P")
            Sheets("KONTROL").Cells(z, "L") = Sheets("ANA SAYFA").Cells(i, "Q")
            Sheets("KONTROL").Cells(z, "M") = Sheets("ANA SAYFA").Cells(i, "R")
            Sheets("KONTROL").Cells(z, "N") = Sheets("ANA SAYFA").Cells(i, "S")
            Sheets("KONTROL").Cells(z, "O") = Sheets("ANA SAYFA").Cells(i, "T")
            Sheets("KONTROL").Cells(z, "P") = Sheets("ANA SAYFA").Cells(i, "U")
            Sheets("KONTROL").Cells(z, "Q") = Sheets("ANA SAYFA").Cells(i, "V")
            Sheets("KONTROL").Cells(z, "R") = Sheets("ANA SAYFA").Cells(i, "W")
            Sheets("KONTROL").Cells(z, "S") = Sheets("ANA SAYFA").Cells(i, "X")
            Sheets("KONTROL").Cells(z, "T") = Sheets("ANA SAYFA").Cells(i, "Y")
           
            z = z + 1
           
           
            '***************Kontrol sayfasındaki tablonun kenar çizgilerinin oluşturulması************************
                Dim rng As Range
                Set rng = Sheets("KONTROL").Range("A8:T" & z - 1)
           
                With rng.Borders
                    .LineStyle = xlContinuous
                    .Color = vbBlack
                    .Weight = xlThin
                End With
            '*****************************************************************************************************
           
        End If
Next i




End Sub
 

Ekli dosyalar

Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst