Diğer Sayfaya kopyalama ve toplamları alma

[tgtd]

Merhaba üstadlar ekteki örnek dosyadaki sayfa1 deki verileri safya2 ye kopyalamak ve örnekteki gibi toplamlarını almak istiyorum. VBA ile nasıl yapabilirim yardımcı olabilirmisiniz teşekkür ederim

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[dEdE]

Alternatif.

Sub Test()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
        s2.Cells.Clear
        s1.UsedRange.Copy s2.Range("A1")
        ss = s2.Cells(Rows.Count, "E").End(3).Row + 1
        
    For i = 5 To 11
        s2.Cells(ss, i) = Application.WorksheetFunction.Sum(Range(Cells(3, i), Cells(ss - 1, i)))
    Next i
    
    s1.Columns("A:K").Copy
    s2.Columns("A:K").PasteSpecial Paste:=xlPasteFormats
    s2.Cells(ss, 7).ClearContents
    
    With s2.Range("E" & ss, s2.Range("K" & ss))
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlMedium
        .Font.Bold = True
        .NumberFormat = "$ #,##0.00"
        .Interior.Color = 65535
    End With
End Sub

 

[tgtd]

Çok Teşekkürler Üstatlarım Ellerinize sağlık

 

[tgtd]

Üstatlar çalışma kitabında, veri listesi olan 3-4 sayfa var, 1-14 arası verileri bir sayfaya aktarmak istiyorum. Yani tek kod ile Sayfa1 de veri olan 14 satır ı "veri " sayfasına kopyalamak, hemen altına devamında Sayfa2 deki 8 satırı kopyalatarak bir liste oluşturmak istiyorum(Sadece Değerleri kopyalamak formulleri almasın istiyorum.) Yardımlarınız için teşekkürler

 

[dEdE]

Merhaba,
Aşağıdaki kodu örnek dosyanızda bir Modüle yapıştırarak dener misiniz?

Sub Test()
SSay = Sheets.Count - 1
Set s1 = Sheets("veri")
s1.Range("A3:L" & s1.Cells(Rows.Count, "A").End(3).Row).Clear
    For i = 1 To SSay
        ss1 = Sheets(i).Cells(Rows.Count, "A").End(3).Row
        If ss1 > 16 Then ss1 = 16
        ss2 = s1.Cells(Rows.Count, "A").End(3).Row + 1
        Sheets(i).Range("A3:L" & ss1).Copy s1.Cells(ss2, 1)
    Next i
End Sub

 

[Haluk]

Sub Test()
    Dim objConn As Object, RS As Object, strSQL As String, strArgs As String
    
    Sheets("veri").Range("A3:L" & Rows.Count).ClearContents
    
    Set objConn = CreateObject("ADODB.Connection")

    strArgs = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; Readonly=False; DBQ=" & ThisWorkbook.FullName
    objConn.Open strArgs

    strSQL = " Select * From [Sayfa1$A2:L] Where [SIRA NO] Is Not Null" & _
             " Union All " & _
             " Select * From [Sayfa2$A2:L] Where [SIRA NO] Is Not Null" & _
             " Union All " & _
             " Select * From [Sayfa3$A2:L] Where [SIRA NO] Is Not Null" & _
             " Union All " & _
             " Select * From [Sayfa4$A2:L] Where [SIRA NO] Is Not Null"
            
    Set RS = objConn.Execute(strSQL)
    
    Sheets("veri").Range("A3").CopyFromRecordset RS
    
    objConn.Close
    Set objConn = Nothing
End Sub

.

 

[Haluk]

Eğer sayfa sayısı zaman içinde değişiyorsa, en son sırada "veri" isimli sayfa olmak kaydıyla;

Sub Test2()
    Dim objConn As Object, RS As Object, strSQL As String, strArgs As String
    
    Sheets("veri").Range("A3:L" & Rows.Count).ClearContents
    
    Set objConn = CreateObject("ADODB.Connection")

    strArgs = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; Readonly=False; DBQ=" & ThisWorkbook.FullName
    objConn.Open strArgs
    
    For i = 1 To Sheets.Count - 1
        strSQL = strSQL & " Select * From [" & Sheets(i).Name & "$A2:L] Where [SIRA NO] Is Not Null Union All"
    Next
    
    strSQL = Mid(strSQL, 1, Len(strSQL) - 9)
    
    Set RS = objConn.Execute(strSQL)
    
    Sheets("veri").Range("A3").CopyFromRecordset RS
    
    objConn.Close
    Set objConn = Nothing
End Sub

.