Merhaba
konu hakkında yardımcı olabilirmisiniz teşekkürler
https://www.dosya.tc/server31/u9d9mw/parsel.xlsx.html
konu hakkında yardımcı olabilirmisiniz teşekkürler
https://www.dosya.tc/server31/u9d9mw/parsel.xlsx.html
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub sayfalaraAktar()
Application.DisplayAlerts = False
Dim i As Long
Dim sayfalar
ReDim sayfalar(1 To Sheets.Count)
For i = 1 To Sheets.Count
sayfalar(i) = Trim(Sheets(i).Name)
Next i
With Sheets("A BLOK")
For i = 3 To .Cells(Rows.Count, 1).End(3).Row
shf = Trim(.Cells(i, 1).Value)
If Not IsError(Application.Match(shf, sayfalar, 0)) Then
Sheets(shf).Delete
End If
Sheets("Sablon").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = shf
.Cells(i, 1).Resize(, 7).Copy Cells(4, 1)
Next i
.Select
End With
Application.DisplayAlerts = True
End Sub
hocam çok teşekkür ederim. 2 satır kopyalamak istersem ne yapmam gerekir kodun üzerinde yani 20001 abone kodu iki tane alt alta olacak şekilde.
Sub sayfalaraAktar()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim i As Long, sat As Long
Dim sayfalar
ReDim sayfalar(1 To Sheets.Count)
For i = 1 To Sheets.Count
sayfalar(i) = Trim(Sheets(i).Name)
Next i
Sheets("A BLOK").Copy After:=Sheets(Sheets.Count)
With ActiveSheet
While .Cells(3, 1).Value <> ""
shf = Trim(.Cells(3, 1).Value)
If Not IsError(Application.Match(shf, sayfalar, 0)) Then
Sheets(shf).Delete
End If
Sheets("Sablon").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = shf
sat = 4
For i = 3 To .Cells(Rows.Count, 1).End(3).Row
If Trim(.Cells(i, 1).Value) = shf Then
.Cells(i, 1).Resize(, 7).Copy Cells(sat, 1)
sat = sat + 1
.Rows(i).Delete
End If
Next i
Wend
.Select
.Delete
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub