Skip to main content

AccessTr.neT


Verileri Sayfalara Ayırma

Verileri Sayfalara Ayırma

Çözüldü #1
Arkadaşlar merhaba,
Ekli örnek dosyada mevcut A sütunundaki "KOD"  bilgileri aynı olan verileri KOD ismi ile aynı olacak
şekilde sayfalara ayırmak istiyorum.
Konuyla ilgili bilgi ve yardımlarınızı rica ediyorum.
Saygılarımla,
.rar sayfalara_ayırma.rar (Dosya Boyutu: 7,6 KB | İndirme Sayısı: 3)
Cevapla
#2
Alt+F11 ile kod sayfasına girin
yeni bir modül ekleyip aşağıdaki kodu yapıştırın
Sub VeriBolSyf()
   Const lngNameCol = 1 ' verilerin alınacağı sütun KODların olduğu A sütünu
   Const lngFirstRow = 2 ' verilerin başladığı satır
   Dim wshSource As Worksheet
   Dim wshTarget As Worksheet
   Dim lngRow As Long
   Dim lngLastRow As Long
   Dim lngTargetRow As Long
   Application.ScreenUpdating = False
   Set wshSource = ActiveSheet
   lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngNameCol).End(xlUp).Row
   For lngRow = lngFirstRow To lngLastRow
       If wshSource.Cells(lngRow, lngNameCol).Value <> wshSource.Cells(lngRow - 1, lngNameCol).Value Then
           Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
           wshTarget.Name = wshSource.Cells(lngRow, lngNameCol).Value
           wshSource.Rows(lngFirstRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
           lngTargetRow = 2
       End If
       wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
       lngTargetRow = lngTargetRow + 1
   Next lngRow
   Application.ScreenUpdating = True
End Sub
kod sayfasını kapatıp normal Excel sayfasına geçip
"görünüm" sekmesinde "makrolar" ı açıp "VeriBolSyf" seçin
dilerim işinize yarar.
.rar sayfalara_ayırma.rar (Dosya Boyutu: 11,33 KB | İndirme Sayısı: 7)
Cevapla
Heart #3
(21/03/2019, 23:57)haliliyas yazdı: Alt+F11 ile kod sayfasına girin
yeni bir modül ekleyip aşağıdaki kodu yapıştırın
Sub VeriBolSyf()
   Const lngNameCol = 1 ' verilerin alınacağı sütun KODların olduğu A sütünu
   Const lngFirstRow = 2 ' verilerin başladığı satır
   Dim wshSource As Worksheet
   Dim wshTarget As Worksheet
   Dim lngRow As Long
   Dim lngLastRow As Long
   Dim lngTargetRow As Long
   Application.ScreenUpdating = False
   Set wshSource = ActiveSheet
   lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngNameCol).End(xlUp).Row
   For lngRow = lngFirstRow To lngLastRow
       If wshSource.Cells(lngRow, lngNameCol).Value <> wshSource.Cells(lngRow - 1, lngNameCol).Value Then
           Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
           wshTarget.Name = wshSource.Cells(lngRow, lngNameCol).Value
           wshSource.Rows(lngFirstRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
           lngTargetRow = 2
       End If
       wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
       lngTargetRow = lngTargetRow + 1
   Next lngRow
   Application.ScreenUpdating = True
End Sub
kod sayfasını kapatıp normal Excel sayfasına geçip
"görünüm" sekmesinde "makrolar" ı açıp "VeriBolSyf" seçin
dilerim işinize yarar.


desteğiniz için çoook teşekkür ediyorum..hemen deneyeceğim hocam
Cevapla
#4
olumlu yada olumsuz sonucu bildirir misiniz?
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da