Problem executing VBA code

sofas

Well-known Member
Joined
Sep 11, 2022
Messages
559
Office Version
  1. 2021
  2. 2019
Platform
  1. Windows
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.

VBA Code:
[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]
 
Last edited:

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
VBA Code:
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
 
Upvote 0
VBA Code:
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?
 
Upvote 0
Try this on a copy of your Workbook as unexpected results may occur.
VBA Code:
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
 
Upvote 1
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)
 
Upvote 0
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.
VBA Code:
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
 
Upvote 0
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.
VBA Code:
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
 
Upvote 0
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?
 
Upvote 0
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


 
Upvote 0
FYI - Going on holiday and won't be able to look at this for a couple of weeks.
 
Upvote 0

Forum statistics

Threads
1,223,884
Messages
6,175,177
Members
452,615
Latest member
bogeys2birdies

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top