İki koşula göre verileri AA sayfasına çekme

isakaratastan · 11 Temmuz 2023

Merhaba,
"GÜNLÜK MÜLAKAT TOPLAM LİSTE" sayfasındaki belli sütun ve satırları "AA" sayfasına mülakat sonucu "OLUMLU" ve "OLABİLİR" olan satırları getirmek istiyorum.
Aynı zamanda önce "H" sonra "G" sütununa göre sıralanmasını istiyorum.
Aşağıda göründüğü gibi belli bir yere kadar yaptım ama fazlasına bilgim yetmedi.
yardımcı olmanızı rica ederim...

Private Sub CommandButton1_Click()
Range("a12:I1000").ClearContents

Dim ilk
Dim son
Dim Birim
Dim dongu
Dim dongu2

ilk = 7
son = 800
Birim = ("OLUMLU")

For dongu = ilk To son
dongu2 = WorksheetFunction.CountIf(Range("b12:b1000"), "<>") + 12
If Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 9) = Birim Then Cells(dongu2, 2) = Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 3)
If Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 9) = Birim Then Cells(dongu2, 3) = Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 4)
If Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 9) = Birim Then Cells(dongu2, 4) = Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 5)
If Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 9) = Birim Then Cells(dongu2, 5) = Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 9)
If Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 9) = Birim Then Cells(dongu2, 6) = Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 10)
If Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 9) = Birim Then Cells(dongu2, 7) = Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 11)
If Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 9) = Birim Then Cells(dongu2, 8) = Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 13)
If Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 9) = Birim Then Cells(dongu2, 9) = Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 14)
If Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 9) = Birim Then Cells(dongu2, 10) = Worksheets("GÜNLÜK MÜLAKAT TOPLAM LİSTE").Cells(dongu, 15)

Next dongu

For i = 12 To Range("b800").End(3).Row
If Cells(i, 2).Value = "" Then
Cells(i, 1).Value = ""
Else
s = s + 1
Cells(i, 1).Value = s
End If

Next i

End Sub

Korhan Ayhan · 12 Temmuz 2023

Deneyiniz.

C++:

Private Sub CommandButton1_Click()
    Dim My_Connection As Object, My_Recordset As Object, My_Query As String
   
    Application.ScreenUpdating = False
   
    Set My_Connection = CreateObject("AdoDB.Connection")
    Set My_Recordset = CreateObject("ADODB.Recordset")
   
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
   
    My_Query = "Select F3,F4,F5,F9,F10,F11,Format(F13,'dd.mm.yyyy'),F14,F15 From [GÜNLÜK MÜLAKAT TOPLAM LİSTE$A6:O] " & _
               "Where F9 Like 'OLUMLU' Or F9 Like 'OLABİLİR' Or F10 Like 'OLUMLU' Or F10 Like 'OLABİLİR' " & _
               "Order By F8,F7 Asc"
   
    My_Recordset.Open My_Query, My_Connection, 3, 1
   
    Range("A12:J" & Rows.Count).ClearContents
    Range("B12").CopyFromRecordset My_Recordset
    
    Range("A12:A" & Cells(Rows.Count, 2).End(3).Row).Formula = "=ROW(A1)"
    Range("A12:A" & Rows.Count).NumberFormat = "General"
    Range("A11:J" & Rows.Count).Sort Range("H12"), xlAscending, Range("G12"), , xlAscending, , , xlYes
    
    Columns.AutoFit
    
    My_Recordset.Close
    My_Connection.Close
   
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

isakaratastan · 12 Temmuz 2023

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Private Sub CommandButton1_Click()
    Dim My_Connection As Object, My_Recordset As Object, My_Query As String
  
    Application.ScreenUpdating = False
  
    Set My_Connection = CreateObject("AdoDB.Connection")
    Set My_Recordset = CreateObject("ADODB.Recordset")
  
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
  
    My_Query = "Select F3,F4,F5,F9,F10,F11,Format(F13,'dd.mm.yyyy'),F14,F15 From [GÜNLÜK MÜLAKAT TOPLAM LİSTE$A6:O] " & _
               "Where F9 Like 'OLUMLU' Or F9 Like 'OLABİLİR' Or F10 Like 'OLUMLU' Or F10 Like 'OLABİLİR' " & _
               "Order By F8,F7 Asc"
  
    My_Recordset.Open My_Query, My_Connection, 3, 1
  
    Range("A12:J" & Rows.Count).ClearContents
    Range("B12").CopyFromRecordset My_Recordset
   
    Range("A12:A" & Cells(Rows.Count, 2).End(3).Row).Formula = "=ROW(A1)"
    Range("A12:A" & Rows.Count).NumberFormat = "General"
    Range("A11:J" & Rows.Count).Sort Range("H12"), xlAscending, Range("G12"), , xlAscending, , , xlYes
   
    Columns.AutoFit
   
    My_Recordset.Close
    My_Connection.Close
  
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
  
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Hocam elinize sağlık güzel olmuş sadece ben ufacık yanlış anlatmışım. "I" ve "J" sütununda olumsuz yazan hiç bir satırın aktarmasını istemiyorum.
yani "I" ve "J" sütunundan her hangi birine olumsuz yazıyorsa o satırı aktarmasın

Korhan Ayhan · 12 Temmuz 2023

Deneyiniz.

C++:

Private Sub CommandButton1_Click()
    Dim My_Connection As Object, My_Recordset As Object, My_Query As String
  
    Application.ScreenUpdating = False
  
    Set My_Connection = CreateObject("AdoDB.Connection")
    Set My_Recordset = CreateObject("ADODB.Recordset")
  
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
  
    My_Query = "Select T1.F3,T1.F4,T1.F5,T1.F9,T1.F10,T1.F11,Format(T1.F13,'dd.mm.yyyy'),T1.F14,T1.F15 From " & _
               "(Select Iif(F9='OLUMSUZ' Or F10='OLUMSUZ','X','') As Say,* From [GÜNLÜK MÜLAKAT TOPLAM LİSTE$A6:O] " & _
               "Where F9 In ('OLUMLU','OLABİLİR') Or F10 In ('OLUMLU','OLABİLİR') Order By F8,F7 Asc) As T1 Where T1.Say<>'X'"
  
    My_Recordset.Open My_Query, My_Connection, 3, 1
  
    Range("A12:J" & Rows.Count).ClearContents
    Range("B12").CopyFromRecordset My_Recordset
   
    Range("A12:A" & Cells(Rows.Count, 2).End(3).Row).Formula = "=ROW(A1)"
    Range("A12:A" & Rows.Count).NumberFormat = "General"
    Range("A11:J" & Rows.Count).Sort Range("H12"), xlAscending, Range("G12"), , xlAscending, , , xlYes
   
    Columns.AutoFit
   
    My_Recordset.Close
    My_Connection.Close
  
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
  
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

isakaratastan · 13 Temmuz 2023

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Private Sub CommandButton1_Click()
    Dim My_Connection As Object, My_Recordset As Object, My_Query As String
 
    Application.ScreenUpdating = False
 
    Set My_Connection = CreateObject("AdoDB.Connection")
    Set My_Recordset = CreateObject("ADODB.Recordset")
 
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
 
    My_Query = "Select T1.F3,T1.F4,T1.F5,T1.F9,T1.F10,T1.F11,Format(T1.F13,'dd.mm.yyyy'),T1.F14,T1.F15 From " & _
               "(Select Iif(F9='OLUMSUZ' Or F10='OLUMSUZ','X','') As Say,* From [GÜNLÜK MÜLAKAT TOPLAM LİSTE$A6:O] " & _
               "Where F9 In ('OLUMLU','OLABİLİR') Or F10 In ('OLUMLU','OLABİLİR') Order By F8,F7 Asc) As T1 Where T1.Say<>'X'"
 
    My_Recordset.Open My_Query, My_Connection, 3, 1
 
    Range("A12:J" & Rows.Count).ClearContents
    Range("B12").CopyFromRecordset My_Recordset
  
    Range("A12:A" & Cells(Rows.Count, 2).End(3).Row).Formula = "=ROW(A1)"
    Range("A12:A" & Rows.Count).NumberFormat = "General"
    Range("A11:J" & Rows.Count).Sort Range("H12"), xlAscending, Range("G12"), , xlAscending, , , xlYes
  
    Columns.AutoFit
  
    My_Recordset.Close
    My_Connection.Close
 
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

çok Sağolun hocam teşekkür ederim.

isakaratastan · 27 Temmuz 2023

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Private Sub CommandButton1_Click()
    Dim My_Connection As Object, My_Recordset As Object, My_Query As String
  
    Application.ScreenUpdating = False
  
    Set My_Connection = CreateObject("AdoDB.Connection")
    Set My_Recordset = CreateObject("ADODB.Recordset")
  
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
  
    My_Query = "Select F3,F4,F5,F9,F10,F11,Format(F13,'dd.mm.yyyy'),F14,F15 From [GÜNLÜK MÜLAKAT TOPLAM LİSTE$A6:O] " & _
               "Where F9 Like 'OLUMLU' Or F9 Like 'OLABİLİR' Or F10 Like 'OLUMLU' Or F10 Like 'OLABİLİR' " & _
               "Order By F8,F7 Asc"
  
    My_Recordset.Open My_Query, My_Connection, 3, 1
  
    Range("A12:J" & Rows.Count).ClearContents
    Range("B12").CopyFromRecordset My_Recordset
   
    Range("A12:A" & Cells(Rows.Count, 2).End(3).Row).Formula = "=ROW(A1)"
    Range("A12:A" & Rows.Count).NumberFormat = "General"
    Range("A11:J" & Rows.Count).Sort Range("H12"), xlAscending, Range("G12"), , xlAscending, , , xlYes
   
    Columns.AutoFit
   
    My_Recordset.Close
    My_Connection.Close
  
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
  
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Hocam merhaba sıralamaya bi ("B12") sutün daha ekleme durumunuz olur mu,
Range("A11:J" & Rows.Count).Sort Range("H12"), xlAscending, Range("G12"), , xlAscending, , , xlYes

İki koşula göre verileri AA sayfasına çekme

isakaratastan

Ekli dosyalar

Korhan Ayhan

Administrator

isakaratastan

Korhan Ayhan

Administrator

isakaratastan

isakaratastan