+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Verileri Sayfalara Ayırma (/konu-verileri-sayfalara-ayirma.html)
Verileri Sayfalara Ayırma - amelie - 21/03/2019
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,
Cvp: Verileri Sayfalara Ayırma - berduş - 21/03/2019
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"görünüm" sekmesinde "makrolar" ı açıp "VeriBolSyf" seçin
dilerim işinize yarar.
Cvp: Verileri Sayfalara Ayırma - amelie - 22/03/2019
(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
kod sayfasını kapatıp normal Excel sayfasına geçipSub 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
"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
Cvp: Verileri Sayfalara Ayırma - berduş - 26/03/2019
olumlu yada olumsuz sonucu bildirir misiniz?