Problem executing VBA code

[sofas]

I am trying to transfer data from Sheet 1 to Sheet 2, paste every 10 separate rows, calculate the sum of the value of column M for every 10 rows in row 11, and write the word TOTAL under column J, inserting 5 empty rows between each range and the other.

[CODE] WSdest.Range("A" & fin) = WSdata.Range("A" & x)

 WSdest.Range("B" & fin) = WSdata.Range("B" & x)

 WSdest.Range("C" & fin) = WSdata.Range("C" & x)


 *

'Is it possible to shorten only these rows instead of
'writing the names of the 16 columns that currently exist?[/CODE]

 

[Skyybot]

Try this on a copy of your Workbook as unexpected results may occur.

Option Explicit
Option Base 1

Sub CopyRows()
Dim wb As Workbook, wsData As Worksheet, wsDest As Worksheet, cRng As Range, lRow As Long, i As Long, y As Long, x As Long
Set wb = ThisWorkbook: Set wsData = wb.Sheets("Sheet1"): Set wsDest = wb.Sheets("Sheet2")
lRow = wsData.Rows.End(xlDown).Row
Set cRng = wsData.Range("A1:Q" & lRow)
i = 1
y = 1
x = 1
Do Until x > lRow
    Do Until i > 10
        If IsEmpty(wsData.Range("A" & x)) Then Exit Do
        wsData.Rows(x).Copy wsDest.Rows(y)
        i = i + 1: y = y + 1: x = x + 1
    Loop
    wsDest.Range("J" & y) = "Total": wsDest.Cells(y, "M").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    i = 1
    y = y + 5
Loop
End Sub

 

[Skyybot]

Option Explicit
Option Base 1

Sub CopyRows()
Dim wb As Workbook, wsData As Worksheet, wsDest As Worksheet, cRng As Range, lRow As Long, i As Long, y As Long, x As Long
Application.ScreenUpdating = False
Set wb = ThisWorkbook: Set wsData = wb.Sheets("Sheet1"): Set wsDest = wb.Sheets("Sheet2")
lRow = wsData.Rows.End(xlDown).Row
Set cRng = wsData.Range("A1:P" & lRow)
i = 1
y = 4
x = 3
cRng.Rows(1).Copy wsDest.Cells(1, 1)
cRng.Rows(2).Copy wsDest.Cells(3, 1)
Application.CutCopyMode = False
Do Until x > lRow
    Do Until i > 10
        If IsEmpty(cRng.Range("A" & x)) Then Exit Do
        cRng.Rows(x).Copy wsDest.Cells(y, 1)
        Application.CutCopyMode = False
        i = i + 1: y = y + 1: x = x + 1
    Loop
    wsDest.Range("J" & y) = "Total": wsDest.Cells(y, "M").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    wsDest.Cells(y, "O").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)": wsDest.Cells(y, "P").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    wsDest.Range("J" & y & ":P" & y).Interior.Color = 65535
    i = 1
    y = y + 2
    cRng.Rows(1).Copy wsDest.Cells(y, 1)
    y = y + 2
    cRng.Rows(2).Copy wsDest.Cells(y, 1)
    Application.CutCopyMode = False
    y = y + 1
Loop
Application.ScreenUpdating = True
End Sub

 

[sofas]

Sub test()



Dim fin, départe, x As Long, fndRow As Long

Dim WSdata As Worksheet: Set WSdata = Worksheets("Sheet1")

Dim WSdest As Worksheet: Set WSdest = Worksheets("Sheet2")



départe = 1

' Paste in row 4

fin = 4



Application.ScreenUpdating = False

For x = 2 To WSdata.Cells(WSdata.Rows.Count, "a").End(xlUp).Row



If WSdata.Range("a" & x) <> "" Then



'copy range ("a3:Q" & lastrow)

    WSdest.Range("A" & ":Q" & fin) = WSdata.Range("A" & x & ":Q" & x)

 

 

 'Number of empty rows

If départe = 10 Then



  fin = fin + 10

   départe = 1

    Else

      fin = fin + 1

        départe = départe + 1

          End If

            End If

   Next

 '  Row 11 of each column range (M) lists the sum of the value of the ten rows

 

Application.ScreenUpdating = True



End Sub

 

[sofas]

Sub test()



Dim fin, départe, x As Long, fndRow As Long

Dim WSdata As Worksheet: Set WSdata = Worksheets("Sheet1")

Dim WSdest As Worksheet: Set WSdest = Worksheets("Sheet2")



départe = 1

' Paste in row 4

fin = 4



Application.ScreenUpdating = False

For x = 2 To WSdata.Cells(WSdata.Rows.Count, "a").End(xlUp).Row



If WSdata.Range("a" & x) <> "" Then



'copy range ("a3:Q" & lastrow)

    WSdest.Range("A" & ":Q" & fin) = WSdata.Range("A" & x & ":Q" & x)

 

 

 'Number of empty rows

If départe = 10 Then



  fin = fin + 10

   départe = 1

    Else

      fin = fin + 1

        départe = départe + 1

          End If

            End If

   Next

 '  Row 11 of each column range (M) lists the sum of the value of the ten rows

 

Application.ScreenUpdating = True



End Sub

Hello. Is there any idea that enables me to copy the data every 10 separate rows?

 

[sofas]

Thank you. It worked well, although it was a bit slow. In addition, it copies the entire columns on the sheet. Is it possible to specify the last column, such as (" P" ) for example?


I tried changing it here but it is not responding
Set cRng = wsData.Range("A1:P" & lRow)

 

[Skyybot]

This may help speed things up a little. I'm not quite sure what you mean by "Specify the last column". If you only copy ColumnP, you can't total ColumnM, and that would change the code needed entirely.

Option Explicit
Option Base 1

Sub CopyRows()
Dim wb As Workbook, wsData As Worksheet, wsDest As Worksheet, cRng As Range, lRow As Long, i As Long, y As Long, x As Long
Application.ScreenUpdating = False
Set wb = ThisWorkbook: Set wsData = wb.Sheets("Sheet1"): Set wsDest = wb.Sheets("Sheet2")
lRow = wsData.Rows.End(xlDown).Row
Set cRng = wsData.Range("A1:Q" & lRow)
i = 1
y = 1
x = 1
Do Until x > lRow
    Do Until i > 10
        If IsEmpty(wsData.Range("A" & x)) Then Exit Do
        wsData.Rows(x).Copy wsDest.Rows(y)
        Application.CutCopyMode = False
        i = i + 1: y = y + 1: x = x + 1
    Loop
    wsDest.Range("J" & y) = "Total": wsDest.Cells(y, "M").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    i = 1
    y = y + 5
Loop
Application.ScreenUpdating = True
End Sub

 

[sofas]

This may help speed things up a little. I'm not quite sure what you mean by "Specify the last column". If you only copy ColumnP, you can't total ColumnM, and that would change the code needed entirely.

Option Explicit
Option Base 1

Sub CopyRows()
Dim wb As Workbook, wsData As Worksheet, wsDest As Worksheet, cRng As Range, lRow As Long, i As Long, y As Long, x As Long
Application.ScreenUpdating = False
Set wb = ThisWorkbook: Set wsData = wb.Sheets("Sheet1"): Set wsDest = wb.Sheets("Sheet2")
lRow = wsData.Rows.End(xlDown).Row
Set cRng = wsData.Range("A1:Q" & lRow)
i = 1
y = 1
x = 1
Do Until x > lRow
    Do Until i > 10
        If IsEmpty(wsData.Range("A" & x)) Then Exit Do
        wsData.Rows(x).Copy wsDest.Rows(y)
        Application.CutCopyMode = False
        i = i + 1: y = y + 1: x = x + 1
    Loop
    wsDest.Range("J" & y) = "Total": wsDest.Cells(y, "M").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    i = 1
    y = y + 5
Loop
Application.ScreenUpdating = True
End Sub

I mean copying columns from A to P only. I tried the code to copy any column present in the file without exception

 

[Skyybot]

I mean copying columns from A to P only. I tried the code to copy any column present in the file without exception

Oh. Yes, the edit you made should work. Check syntax maybe?

 

[sofas]

Oh. Yes, the edit you made should work. Check syntax maybe?

Thank you for paying attention to my request. Please, can you take a look at the file? Your code has been included with the expected result

TEST COPY

MediaFire is a simple to use free service that lets you put all your photos, documents, music, and video in a single place so you can access them anywhere and share them everywhere.

www.mediafire.com