Farklı yerlerdeki hücreleri satır haline getirip kaydetme.

[kelkitli]

Değerli Dostlar Selamlar,
Ekteki dosyada belirttiğim Sayfa1 deki B1,B2,C3,D4,B6,C7,C8,D9
Buradaki hücreler bu sıra ile Sayfa2 en son satıra B sütunundan itibaren satır olarak aktarılacak.Sayfa2 A sütunu A2 den itibaren otomatik sayı olacak. Satırın tüm hücreleri tıpatıp aynı önceden var ise üzerine kaydedilecek.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Private Sub CommandButton1_Click()
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    S2.[IV:IV].ClearContents
    Sütun = 2
    Son_Satır = S2.[B65536].End(3).Offset(1).Row
    For X = 2 To S2.[B65536].End(3).Row
    Son_Sütun = S2.Cells(X, 256).End(1).Column
    For Y = 2 To Son_Sütun
    If S2.Cells(X, Y) <> "" Then
    S2.Cells(X, 256) = S2.Cells(X, 256) & S2.Cells(X, Y)
    End If
    Next
    Next
    For Each Alan In S1.Columns("B:D").SpecialCells(xlCellTypeConstants, 23)
    Kriter = Kriter & Alan.Value
    Next
    Say = WorksheetFunction.CountIf(S2.[IV:IV], Kriter)
    If Say > 0 Then
    Sat&#305;r = S2.[IV:IV].Find(Kriter, LookAt:=xlWhole).Row
    S2.Cells(Sat&#305;r, 1) = Sat&#305;r - 1
    For Each Alan In S1.Columns("B:D").SpecialCells(xlCellTypeConstants, 23)
    S2.Cells(Sat&#305;r, S&#252;tun) = Alan.Value
    S&#252;tun = S&#252;tun + 1
    Next
    ElseIf Say = 0 Then
    S2.Cells(Son_Sat&#305;r, 1) = Son_Sat&#305;r - 1
    For Each Alan In S1.Columns("B:D").SpecialCells(xlCellTypeConstants, 23)
    S2.Cells(Son_Sat&#305;r, S&#252;tun) = Alan.Value
    S&#252;tun = S&#252;tun + 1
    Next
    End If
    S2.[IV:IV].ClearContents
    Set S1 = Nothing
    Set S2 = Nothing
    MsgBox "KAYIT &#304;&#350;LEM&#304; TAMAMLANMI&#350;TIR.", vbInformation
End Sub

 

[kelkitli]

Teşekkür ederim Sayın COST CONTROL,
Çok güzel olmuş. Ancak bu kadar olabilirdi. Eksiksiz.
Elinize sağiık.

 

[kelkitli]

Sayın COST_CONTROL şöyle bir ilave yapabilirmiyiz.

Sub aktar()
Range("B2,B4,B6").Select
Range("B6").Activate
Selection.Copy
Sheets("Sayfa3").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
True, Transpose:=True
End Sub

Bu tür bir uygulamayı Son dolu satırın sonununa ilave edeceğiz. Sayfa3 e
A Sütunu Yine otomatik sıra olmalı. Şimdiden teşekkürler.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki şekilde denermisiniz.

Sub Aktar()
    Range("B2,B4,B6").Select
    Range("B6").Activate
    Selection.Copy
    Sheets("Sayfa3").Select
    Son_Satır = Range("B65536").End(3).Offset(1).Row
    Range("A" & Son_Satır) = Son_Satır - 1
    Range("B65536").End(3).Offset(1).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    True, Transpose:=True
    Application.CutCopyMode = False
End Sub

 

[kelkitli]

Cevabınız için teşekkür ederim Sayın COST_CONTROL,
Veri tıpatıp aynı olursa Mükerrer kayıt olunca üzerine yazdırabilirmiyiz. Yada kaydetmesin.

 

[Korhan Ayhan]

Selamlar,

Anlam veremediğim mükerrer kayıt olunca neden üzerine kaydetmesini istemeniz. Zaten kayıt sayfada mevcutsa neden tekrar üzerine kaydetmesi gerekiyor.

Ayrıca kullanmak istediğiniz son koda mükerrer kayıt kontrolü eklemek için verileri döngü içine almak gerekecektir. Bunuda zaten ilk cevabımda vermiştim.

 

[kelkitli]

Sayın COST_CONTROL bir önceki mesajı düzeltmiştim de herhalde siz cevabı okuduktan sonra düzeltmişimdir. Ben ilk mesaja bu sonraki şekli entegre edemedim. Sağol size yeterince zahmet verdim uyarlamaya uğraşacağım sağol varol. Emeğine sağlık. Zaten size emeklerinizden dolayı mahçup kalıyorum.

 

[kelkitli]

Selamlar,
Değerli arkadaşlar, mükerrer kayıt önleme için şöyle bir şey hazırladım.

Sub Aktar()
Range("B2,B4,B6,B8,B10,B12").Select
Range("B6").Activate
Selection.Copy
Sheets("Sayfa3").Select
Son_Satır = Range("B65536").End(3).Offset(1).Row
Range("A" & Son_Satır) = Son_Satır - 1
Range("B65536").End(3).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=True
Application.CutCopyMode = False
[H1].FormulaR1C1 = "=RC[-6]&RC[-5]&RC[-4]&RC[-3]&RC[-2]&RC[-1]"
[H1].AutoFill Destination:=[H1:H120]
[I1].FormulaR1C1 = "=COUNTIF(R1C8:RC[-1],RC[-1])"
[I1].AutoFill Destination:=[I1:I120]
For X = [A65536].End(3).Row To 2 Step -1
If Cells(X, 9) > 1 Then Rows(X).Delete
Next
Columns("H:I").ClearContents
Sayfa1.Select
End Sub

Daha pratik çözümlerinizi de beklerim.

 

[bilalakdeniz]

Merhabalar Arkadaşlar bu aktarımın bana aynı kayıdı yapmayan olarak gönderebilirmisiniz?