Verileri ayrı sütundaki değerlere göre ayrı sayfalarda ayırma

[spiderman061]

Hocam bu formül HAM_TXT sayfasındaki verileri a sutundaki verilere göre sayfalar oluşturarak ayırıyor. Ben sadece A,B,C sutunlarındaki verileri ayırsın ve A-B sutunundaki veriler yer değiştirsin istiyorum. kısaca A-B-C sutunlarını B-A-C olarak sayfalara dağıtsın istiyorum. (ilk satırı almasın) yardımcı olabilirseniz çok memnun olurum.

Sub VERIAYIR()
Dim xSht As Worksheet
Dim xNSht As Worksheet
Dim I As Long
Dim xTRrow As Integer
Dim xCol As New Collection
Dim xTitle As String
Dim xSUpdate As Boolean
Set xSht = Sheets("HAM_TXT")
On Error Resume Next
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
xTitle = "A:A"
xTRrow = xSht.Range(xTitle).Cells(1).Row
For I = 1 To xRCount
Call xCol.Add(xSht.Cells(I, 1).Text, xSht.Cells(I, 1).Text)
Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 2 To xCol.Count
Call xSht.Range(xTitle).AutoFilter(1, CStr(xCol.Item(I)))
Set xNSht = Nothing
Set xNSht = Worksheets(CStr(xCol.Item(I)))
If xNSht Is Nothing Then
Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
xNSht.Name = CStr(xCol.Item(I))
Else
xNSht.Move , Sheets(Sheets.Count)
End If
xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
xNSht.Columns.AutoFit
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate
End Sub

Alıntı Cevapla
Şikayet Et!

 

[PLİNT]

Merhaba
Kodlarınızın sonlarında (En alttan yukarı 7.satır) bulunan şu Tek satırı silip yerine aşağıdaki 3 satırı ekleyip deneyiniz?
Bunun yerine

xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")

Şu satırları

xSht.Range("A" & xTRrow & ":A" & xRCount).Copy xNSht.Range("B1")
xSht.Range("B" & xTRrow & ":B" & xRCount).Copy xNSht.Range("A1")
xSht.Range("C" & xTRrow & ":C" & xRCount).Copy xNSht.Range("C1")

 

[PLİNT]

"İlk satır olmasın" notunuz varmış

xSht.Range("A" & xTRrow + 1 & ":A" & xRCount).Copy xNSht.Range("B1")
xSht.Range("B" & xTRrow + 1 & ":B" & xRCount).Copy xNSht.Range("A1")
xSht.Range("C" & xTRrow + 1 & ":C" & xRCount).Copy xNSht.Range("C1")

Ama sayfalarında ikinci satırından itibaren eklenecekse;

xSht.Range("A" & xTRrow + 1 & ":A" & xRCount).Copy xNSht.Range("B2")
xSht.Range("B" & xTRrow + 1 & ":B" & xRCount).Copy xNSht.Range("A2")
xSht.Range("C" & xTRrow + 1 & ":C" & xRCount).Copy xNSht.Range("C2")

 

[spiderman061]

Hocam elinize sağlık. çok güzel çalıştı. Ufak bir sıkıntı var
Kopyaladığı sütunlar formülle hesaplanmış sütunlar. Değer olarak yapıştırma şansımız var mı? formülleri kopyalıyor

=SAYIYAÇEVİR(PARÇAAL(C1;16;8))

#DEĞER!​

#DEĞER!​

#DEĞER!​

#DEĞER!​

#DEĞER!​

#DEĞER!​

#DEĞER!​

#DEĞER!​

#DEĞER!​

#DEĞER!​

 

[PLİNT]

O üç satırın yerine; şu 6 satırı ekleyerek deneyin

xSht.Range("A" & xTRrow + 1 & ":A" & xRCount).Copy
xNSht.Range("B2").PasteSpecial Paste:=xlPasteValues
xSht.Range("B" & xTRrow + 1 & ":B" & xRCount).Copy
xNSht.Range("A2").PasteSpecial Paste:=xlPasteValues
xSht.Range("C" & xTRrow + 1 & ":C" & xRCount).Copy
xNSht.Range("C2").PasteSpecial Paste:=xlPasteValues

olmazsa sayı formatlı için

xSht.Range("A" & xTRrow + 1 & ":A" & xRCount).Copy
xNSht.Range("B2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
xSht.Range("B" & xTRrow + 1 & ":B" & xRCount).Copy
xNSht.Range("A2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
xSht.Range("C" & xTRrow + 1 & ":C" & xRCount).Copy
xNSht.Range("C2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

 

[spiderman061]

çoooook teşekkür ediyorum, Tuttuğunuz altın olsun