Merhabalar. Elimde bir excel tablom var. Burada anahtar kelimeye göre süzme işlemi yaptırmak istiyorum. Lakin ne yaptıysam ayarlayamadım. Kodda yapılan işlemleri kısaca anlatayım. Veri giriş kitabındaki b sütunundan süzülen veri kitabındaki a sütununda bulunan anahtar kelimeye göre süzme işlemi yapıyor. Ama aynı anahtar kelime aynı satırda var ise sadece ilk anahtar kelimeyi alıp diğerlerini yok sayıyor. Süzme işlemini excel yaparken anahtar kelime büyük harflerde oluşuyorsa ona göre süzme yapıyor. Ama bazı veriler büyük harflerle, bazıları baş harfi büyük, bazıları ise tamamen küçük harflerle yazılı. Ama mantıken anahtar kelime ne ise ona göre ayarlamaya çalışıyorum. Süzme işlemi yaparken anahtar kelime BİLGİSAYAR ise veri giriş kitabından ilgili sütundan 'Bilgisayar', 'bilgisayar', 'BİLGİSAYAR' olanları süzmesini istiyorum. Yapılabilir mi? Birde kodda aynı satırda anahtar kelime birden fazla ise ilk anahtar kelimeyi al diğerlerini yok say dedim ama bu seferde 'Fotokopi Makinası' süzme işleminde sıkıntı oluyor. Bu şekilde olan malzemeler için mesela a30-a50 arasındakileri tam isme göre süz yapamaz mıyız? Teşekkürler.
www.dosya.tc
deneme_duzeltilebilir.XLSM dosyasını indir - download
deneme_duzeltilebilir.XLSM dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
www.dosya.tc
Kod:
Sub VeriSüzVeKaydet()
Dim wsVeri As Worksheet, wsSüzülen As Worksheet
Dim wbYeni As Workbook
Dim rngAnahtar As Range, rngVeri As Range
Dim cell As Range, veriCell As Range
Dim dosyaYolu As String, dosyaAdi As String
Dim sonSatir As Long, satirSayaci As Long
Dim anahtarKelime As String
Dim kelimeDizisi() As String
Dim veriHarfleri As String
Dim kelimeBulundu As Boolean
Dim wsYeni As Worksheet
Dim ilkKelime As String
Dim anahtarKelimeBulundu As Boolean
Dim i As Long ' Döngü değişkeni
Dim toplamOnayli As Double, toplamIptal As Double
Dim toplamOnayliSüzülen As Double, toplamIptalSüzülen As Double
' Hata yönetimi
On Error GoTo HataYakala
' Performans optimizasyonları
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
' Sayfaları tanımla
Set wsVeri = ThisWorkbook.Sheets("Veri Giriş")
Set wsSüzülen = ThisWorkbook.Sheets("Süzülen Veri")
' Anahtar kelimelerin olduğu aralık (A2:A24)
Set rngAnahtar = wsSüzülen.Range("A2:A24")
' Veri girişindeki son satırı bul (B sütunu)
sonSatir = wsVeri.Cells(wsVeri.Rows.Count, 2).End(xlUp).Row
Set rngVeri = wsVeri.Range("B2:B" & sonSatir)
' Masaüstüne klasör oluştur
dosyaYolu = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Süzülen Veriler\"
If Dir(dosyaYolu, vbDirectory) = "" Then MkDir dosyaYolu
' Verileri filtrele ve kaydet
For Each veriCell In rngVeri
If Trim(veriCell.Value) <> "" Then ' Boş hücreleri atla
kelimeBulundu = False
anahtarKelimeBulundu = False
ilkKelime = ""
kelimeDizisi = Split(Trim(veriCell.Value), " ")
' Her kelimeyi kontrol et
For i = 0 To UBound(kelimeDizisi)
veriHarfleri = kelimeDizisi(i)
' Anahtar kelimeler için döngü
For Each cell In rngAnahtar
anahtarKelime = Trim(cell.Value)
' Boş anahtarları atla
If anahtarKelime <> "" Then
' İlk eşleşen anahtar kelimeyi bul
If Not anahtarKelimeBulundu And InStr(1, veriHarfleri, anahtarKelime, vbTextCompare) > 0 Then
kelimeBulundu = True
anahtarKelimeBulundu = True
ilkKelime = anahtarKelime ' İlk eşleşen anahtar kelimeyi kaydet
Exit For
End If
End If
Next cell
If anahtarKelimeBulundu Then Exit For ' İlk eşleşme bulunduysa çık
Next i
' Eğer A16:A24 arası anahtar kelimeleri varsa, onları da kontrol et
If Not anahtarKelimeBulundu Then
For Each cell In wsSüzülen.Range("A16:A24")
anahtarKelime = Trim(cell.Value)
' Anahtar kelimeyi veri içinde arama
If anahtarKelime <> "" And InStr(1, Trim(veriCell.Value), anahtarKelime, vbTextCompare) > 0 Then
kelimeBulundu = True
ilkKelime = anahtarKelime ' İlgili kelimeyi kaydet
Exit For
End If
Next cell
End If
' Eşleşme varsa, dosya adı oluştur ve veriyi kaydet
If kelimeBulundu Then
' Dosya adını belirle
dosyaAdi = dosyaYolu & TemizDosyaAdi(ilkKelime) & ".xlsx"
' Yeni veya mevcut dosyayı aç
If Dir(dosyaAdi) <> "" Then
Set wbYeni = Workbooks.Open(dosyaAdi)
Else
Set wbYeni = Workbooks.Add
End If
Set wsYeni = wbYeni.Sheets(1)
' Başlıkları ekle (eğer boşsa)
If Application.WorksheetFunction.CountA(wsYeni.Range("A:A")) = 0 Then
wsYeni.Range("A1:B1").Value = Array("Kategori", "Tutar")
satirSayaci = 2
Else
satirSayaci = wsYeni.Cells(wsYeni.Rows.Count, 1).End(xlUp).Row + 1
End If
' Veriyi kaydet
wsYeni.Cells(satirSayaci, 1).Value = veriCell.Value
wsYeni.Cells(satirSayaci, 2).Value = wsVeri.Cells(veriCell.Row, 5).Value
' Sütun genişliğini ayarla
wsYeni.Columns("A:B").AutoFit
' Dosyayı kaydet ve kapat
Application.DisplayAlerts = False
If Dir(dosyaAdi) = "" Then
wbYeni.SaveAs dosyaAdi, FileFormat:=xlOpenXMLWorkbook
Else
wbYeni.Save
End If
Application.DisplayAlerts = True
wbYeni.Close False
End If
End If
Next veriCell
' Şimdi A16:A24 arasındaki anahtar kelimelere göre toplamları hesapla
toplamOnayliSüzülen = 0
toplamIptalSüzülen = 0
For Each cell In wsSüzülen.Range("A16:A24")
If Trim(cell.Value) <> "" Then
' Onaylı ve İptal verilerini al
toplamOnayli = Application.WorksheetFunction.SumIf(wsVeri.Range("B2:B" & sonSatir), "*" & cell.Value & "*", wsVeri.Range("E2:E" & sonSatir))
toplamIptal = Application.WorksheetFunction.SumIf(wsVeri.Range("B2:B" & sonSatir), "*" & cell.Value & "*", wsVeri.Range("F2:F" & sonSatir))
' Toplamları ilgili hücrelere yaz
wsSüzülen.Cells(cell.Row, 2).Value = toplamOnayli
End If
Next cell
' Performans ayarlarını geri al
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox "İşlem başarıyla tamamlandı! Dosyalar masaüstünde 'Süzülen Veriler' klasöründe.", vbInformation
Exit Sub
HataYakala:
' Hata mesajını göster
MsgBox "Hata oluştu!" & vbCrLf & _
"Hata Kodu: " & Err.Number & vbCrLf & _
"Açıklama: " & Err.Description, vbCritical
' Performans ayarlarını geri al
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
' Dosya adındaki yasaklı karakterleri temizleyen fonksiyon
Function TemizDosyaAdi(dosyaAdi As String) As String
Dim yasakliKarakterler As String: yasakliKarakterler = "/\:*?""<>|"
Dim i As Integer
For i = 1 To Len(yasakliKarakterler)
dosyaAdi = Replace(dosyaAdi, Mid(yasakliKarakterler, i, 1), "-")
Next i
TemizDosyaAdi = dosyaAdi
End Function