Arkadaşlar merhaba,
Datayı filtreleyip yeni bir excel yaratıp o excele yapıştırmak istiyorum fakat, filtrelenmiş data exceldeki son sütuna kadar aynı datayı tekrar tekrar yapıştırıyor. Ben de çözüm olarak son sütunu bul o sütuna kadar sildirme işlemi yaptırttım ama çalışmıyor. Nasıl düzeltebilirim?
Sub FiltreleVeParcala()
Dim ws As Worksheet
Dim rng As Range
Dim filtreDegerleri As Collection
Dim cell As Range
Dim hedefDosya As Workbook
Dim hedefSayfa As Worksheet
Dim PRODUCT_CODE As Variant
Dim kayitYolu As String
Dim sonSutun As Long
' Aktif çalışma sayfasını seçin
Set ws = ThisWorkbook.Sheets("Sheet1") ' Veri sayfasının adı
' Filtrelenecek sütunun aralığını belirtin (örneğin A sütunu)
Set rng = ws.Range("F1:F" & ws.Cells(ws.Rows.Count, "F").End(xlUp).Row)
' Filtrelenecek değerleri toplamak için bir koleksiyon oluşturun
Set filtreDegerleri = New Collection
On Error Resume Next
For Each cell In rng
If cell.Row > 1 Then ' Başlık satırını atla
filtreDegerleri.Add cell.Value, CStr(cell.Value)
End If
Next cell
On Error GoTo 0
' Kaydetme yolu
kayitYolu = ThisWorkbook.Path & "\"
' Her bir filtre değeri için işlem yap
For Each PRODUCT_CODE In filtreDegerleri
' Yeni bir dosya oluştur
Set hedefDosya = Workbooks.Add
Set hedefSayfa = hedefDosya.Sheets(1)
' Başlık satırını kopyala
'ws.Rows(1).Copy Destination:=hedefSayfa.Rows(1)
' Filtre uygula ve sonuçları kopyala
ws.UsedRange.AutoFilter Field:=6, Criteria1:=PRODUCT_CODE
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=hedefSayfa.Rows(1)
sonSutun = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
If sonSutun > 8 Then
ws.Columns("I:" & ws.Columns(sonSutun).Address(False, False)).Delete
End If
'Dosyayı kaydet
hedefDosya.SaveAs Filename:=kayitYolu & PRODUCT_CODE & ".xlsx"
hedefDosya.Close SaveChanges:=False
Next PRODUCT_CODE
' Filtreyi temizle
ws.AutoFilterMode = False
MsgBox "İşlem tamamlandı! Dosyalar kaydedildi: " & kayitYolu
End Sub
Datayı filtreleyip yeni bir excel yaratıp o excele yapıştırmak istiyorum fakat, filtrelenmiş data exceldeki son sütuna kadar aynı datayı tekrar tekrar yapıştırıyor. Ben de çözüm olarak son sütunu bul o sütuna kadar sildirme işlemi yaptırttım ama çalışmıyor. Nasıl düzeltebilirim?
Sub FiltreleVeParcala()
Dim ws As Worksheet
Dim rng As Range
Dim filtreDegerleri As Collection
Dim cell As Range
Dim hedefDosya As Workbook
Dim hedefSayfa As Worksheet
Dim PRODUCT_CODE As Variant
Dim kayitYolu As String
Dim sonSutun As Long
' Aktif çalışma sayfasını seçin
Set ws = ThisWorkbook.Sheets("Sheet1") ' Veri sayfasının adı
' Filtrelenecek sütunun aralığını belirtin (örneğin A sütunu)
Set rng = ws.Range("F1:F" & ws.Cells(ws.Rows.Count, "F").End(xlUp).Row)
' Filtrelenecek değerleri toplamak için bir koleksiyon oluşturun
Set filtreDegerleri = New Collection
On Error Resume Next
For Each cell In rng
If cell.Row > 1 Then ' Başlık satırını atla
filtreDegerleri.Add cell.Value, CStr(cell.Value)
End If
Next cell
On Error GoTo 0
' Kaydetme yolu
kayitYolu = ThisWorkbook.Path & "\"
' Her bir filtre değeri için işlem yap
For Each PRODUCT_CODE In filtreDegerleri
' Yeni bir dosya oluştur
Set hedefDosya = Workbooks.Add
Set hedefSayfa = hedefDosya.Sheets(1)
' Başlık satırını kopyala
'ws.Rows(1).Copy Destination:=hedefSayfa.Rows(1)
' Filtre uygula ve sonuçları kopyala
ws.UsedRange.AutoFilter Field:=6, Criteria1:=PRODUCT_CODE
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=hedefSayfa.Rows(1)
sonSutun = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
If sonSutun > 8 Then
ws.Columns("I:" & ws.Columns(sonSutun).Address(False, False)).Delete
End If
'Dosyayı kaydet
hedefDosya.SaveAs Filename:=kayitYolu & PRODUCT_CODE & ".xlsx"
hedefDosya.Close SaveChanges:=False
Next PRODUCT_CODE
' Filtreyi temizle
ws.AutoFilterMode = False
MsgBox "İşlem tamamlandı! Dosyalar kaydedildi: " & kayitYolu
End Sub