Copying rows from several sheets, where sheet data exists, to one sheet of another file in Excel VBA

huangapple
go评论90阅读模式
英文:

Copying rows from several sheets, where sheet data exists, to one sheet of another file in Excel VBA

问题

I need to copy rows with four columns from one workbook containing four sheets "data.xlsx" (sheets 1, 2, 3, 4) to one sheet on another workbook named "newdata.xlsm" (sheet 1).

For sheets 1, 2, 3, 4 in "data.xlsx" the number of rows can be anywhere from 0 to 60 (usually 0 to 20 rows).

When one or several sheets in data.xlsx has zero rows the macro generates

VBA Error 1004 – Application-Defined or Object-Defined Error

If for example sheet 2 has zero rows. Excel gets an error on:

  1. 'copy 
  2. column 1 worksheets("worksheet2").cells(p,1).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(q,1)

as q=0. I understand it is not possible to copy text to row = 0.

I started to dabble with "goto"-statements but quickly surrendered as I realized I was in deep water.

  1. sub copyfile
  3. 'read data.xlsx file
  5. 'open data file
  6. workbooks.open filename :=thisworkbook.path & "\data.xlsx"
  8. dim x as integer
  10. 'dim lr as long
  11. lr= cells(rows.count,1).end(xlup).row
  13. for x = 2 to lr
  15. 'copy rows from sheet1 on data.xlsx to new file, new file called "newdata.xlsm"
  17. 'copy column 1 
  18. worksheets("worksheet1").cells(x,1).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(x,1)
  20. 'copy column 2
  21. worksheets("worksheet1").cells(x,2).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(x,2)
  23. 'copy column 3
  24. worksheets("worksheet1").cells(x,3).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(x,3)
  26. 'copy column 4
  27. worksheets("worksheet1").cells(x,4).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(x,4)
  29. next x
  31. windows("data.xlsx").Activate
  32. Sheets("Worksheet2").Activate
  34. 'dim copy worksheet 2
  35. dim y as integer
  36. dim z as integer
  37. dim lr_y as long
  39. 'no of rows on worksheet2
  40. lr_y = cells(rows.count,1).end(xlup).row
  41. For y = 2 to lr_y
  43. For z = (y + x) -2 to lr_y + x - 2
  45. 'copy rows from sheet2 on data.xlsx to new file, new file called "newdata.xlsm"
  47. 'copy column 1 
  48. worksheets("worksheet2").cells(y,1).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(z,1)
  50. 'copy column 2
  51. worksheets("worksheet2").cells(y,2).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(z,2)
  53. 'copy column 3
  54. worksheets("worksheet2").cells(y,3).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(z,3)
  56. 'copy column 4
  57. worksheets("worksheet2").cells(y,4).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(z,4)
  59. next z
  60. next y
  62. windows("data.xlsx").Activate
  63. Sheets("Worksheet3").Activate
  65. 'dim copy worksheet 3
  66. dim p as integer
  67. dim q as integer
  68. dim lr_p as long
  70. 'no of rows on worksheet3
  71. lr_p = cells(rows.count,1).end(xlup).row
  72. For p = 2 to lr_p
  74. For q = (p+z) -2 to lr_p + z - 2
  76. 'copy column 1 
  77. worksheets("worksheet3").cells(p,1).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(q,1)
  79. 'copy column 2
  80. worksheets("worksheet3").cells(p,2).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(q,2)
  82. 'copy column 3
  83. worksheets("worksheet3").cells(p,3).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(q,3)
  85. 'copy column 4
  86. worksheets("worksheet3").cells(p,4).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(q,4)
  88. next q
  89. next p
  91. windows("data.xlsx").Activate
  92. Sheets("Worksheet4").Activate
  94. 'dim copy worksheet 3
  95. dim r as integer
  96. dim s as integer
  98. 'no of rows on worksheet4
  99. dim lr_p as long
  100. lr_p = cells(rows.count,1).end(xlup).row
  102. For r = 2 to lr_r
  104. For s = (r+q) -2 to lr_r + q - 2
  106. 'copy column 1 
  107. worksheets("worksheet4").cells(r,1).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(s,1)
  109. 'copy column 2
  110. worksheets("worksheet4").cells(r,2).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(s,2)
  112. 'copy column 3
  113. worksheets("worksheet4").cells(r,3).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(s,3)
  115. 'copy column 4
  116. worksheets("worksheet4").cells(r,4).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(s,4)
  118. next s
  119. next r
  121. workbooks("data.xlsx").close

I tried changing:

  1. For q = (p+z) -2 to lr_p + z - 2

to include variants of x, however, this did not work as I need the code to function in both cases, if rows are populated or not.

英文:

I need to copy rows with four columns from one workbook containing four sheets "data.xlsx" (sheets 1, 2, 3, 4) to one sheet on another workbook named "newdata.xlsm" (sheet 1).

For sheets 1, 2, 3, 4 in "data.xlsx" the number of rows can be anywhere from 0 to 60 (usually 0 to 20 rows).

When one or several sheets in data.xlsx has zero rows the macro generates

>VBA Error 1004 – Application-Defined or Object-Defined Error

If for example sheet 2 has zero rows. Excel gets an error on:

  1. 'copy 
  2. column 1 worksheets("worksheet2").cells(p,1).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(q,1)

as q=0. I understand it is not possible to copy text to row = 0.

I started to dabble with "goto"-statements but quickly surrendered as I realized I was in deep water.

  1. sub copyfile
  3. 'read data.xlsx file
  5. 'open data file
  6. workbooks.open filename :=thisworkbook.path & "\data.xlsx"
  8. dim x as integer
  10. 'dim lr as long
  11. lr= cells(rows.count,1).end(xlup).row
  13. for x = 2 to lr
  15. 'copy rows from sheet1 on data.xlsx to new file, new file called "newdata.xlsm"
  17. 'copy column 1 
  18. worksheets("worksheet1").cells(x,1).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(x,1)
  20. 'copy column 2
  21. worksheets("worksheet1").cells(x,2).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(x,2)
  23. 'copy column 3
  24. worksheets("worksheet1").cells(x,3).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(x,3)
  26. 'copy column 4
  27. worksheets("worksheet1").cells(x,4).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(x,4)
  29. next x
  31. windows("data.xlsx").Activate
  32. Sheets("Worksheet2").Activate
  34. 'dim copy worksheet 2
  35. dim y as integer
  36. dim z as integer
  37. dim lr_y as long
  39. 'no of rows on worksheet2
  40. lr_y = cells(rows.count,1).end(xlup).row
  41. For y = 2 to lr_y
  43. For z = (y + x) -2 to lr_y + x - 2
  45. 'copy rows from sheet2 on data.xlsx to new file, new file called "newdata.xlsm"
  47. 'copy column 1 
  48. worksheets("worksheet2").cells(y,1).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(z,1)
  50. 'copy column 2
  51. worksheets("worksheet2").cells(y,2).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(z,2)
  53. 'copy column 3
  54. worksheets("worksheet2").cells(y,3).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(z,3)
  56. 'copy column 4
  57. worksheets("worksheet2").cells(y,4).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(z,4)
  59. next z
  60. next y
  62. windows("data.xlsx").Activate
  63. Sheets("Worksheet3").Activate
  65. 'dim copy worksheet 3
  66. dim p as integer
  67. dim q as integer
  68. dim lr_p as long
  70. 'no of rows on worksheet3
  71. lr_p = cells(rows.count,1).end(xlup).row
  72. For p = 2 to lr_p
  74. For q = (p+z) -2 to lr_p + z - 2
  76. 'copy column 1 
  77. worksheets("worksheet3").cells(p,1).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(q,1)
  79. 'copy column 2
  80. worksheets("worksheet3").cells(p,2).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(q,2)
  82. 'copy column 3
  83. worksheets("worksheet3").cells(p,3).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(q,3)
  85. 'copy column 4
  86. worksheets("worksheet3").cells(p,4).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(q,4)
  88. next q
  89. next p
  91. windows("data.xlsx").Activate
  92. Sheets("Worksheet4").Activate
  94. 'dim copy worksheet 3
  95. dim r as integer
  96. dim s as integer
  98. 'no of rows on worksheet4
  99. dim lr_p as long
  100. lr_p = cells(rows.count,1).end(xlup).row
  102. For r = 2 to lr_r
  104. For s = (r+q) -2 to lr_r + q - 2
  106. 'copy column 1 
  107. worksheets("worksheet4").cells(r,1).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(s,1)
  109. 'copy column 2
  110. worksheets("worksheet4").cells(r,2).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(s,2)
  112. 'copy column 3
  113. worksheets("worksheet4").cells(r,3).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(s,3)
  115. 'copy column 4
  116. worksheets("worksheet4").cells(r,4).copy workbooks("newdata.xlsm").worksheets("sheet1").cells(s,4)
  118. next s
  119. next r
  121. workbooks("data.xlsx").close

I tried changing:

  1. For q = (p+z) -2 to lr_p + z - 2

to include variants of x however this did not work as I need the code to function in both cases, if rows are populated or not.

答案1

得分: 2

以下是代码部分的中文翻译：

  1. Sub copyfile()
  3.     Dim wb As Workbook, wbData As Workbook, i As Long, wsName, lr As Long, ws As Worksheet
  4.     Dim pasteRow As Long
  5.     
  6.     Set wb = ThisWorkbook
  7.     Set wbData = Workbooks.Open(Filename:=ThisWorkbook.Path & "\data.xlsx")
  8.     
  9.     pasteRow = 2  '从这里开始粘贴
  10.     For Each wsName In Array("worksheet1", "worksheet2", "worksheet3", "worksheet4")
  11.         Set ws = wbData.Worksheets(wsName)
  12.         lr = LastOccupiedRow(ws)
  13.         If lr > 1 Then    '第2行及以后有数据吗？
  14.             ws.Range("A2:D" & lr).Copy wb.Worksheets("sheet1").Cells(pasteRow, "A")
  15.             pasteRow = pasteRow + (lr - 1)
  16.         End If
  17.     Next wsName
  18.     
  19.     wbData.Close False
  20.     
  21. End Sub
  23. Function LastOccupiedRow(ws As Worksheet) As Long
  24.     Dim f As Range
  25.     Set f = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
  26.     If Not f Is Nothing Then LastOccupiedRow = f.Row
  27. End Function

请注意，这是您提供的代码的中文翻译，不包括问题或其他内容。

英文:

Much tidier to copy/paste the whole block, and use a loop for the worksheets being copied:

  1. Sub copyfile()
  3.     Dim wb As Workbook, wbData As Workbook, i As Long, wsName, lr As Long, ws As Worksheet
  4.     Dim pasteRow As Long
  5.     
  6.     Set wb = ThisWorkbook
  7.     Set wbData = Workbooks.Open(Filename:=ThisWorkbook.Path & "\data.xlsx")
  8.     
  9.     pasteRow = 2  'start pasting here
  10.     For Each wsName In Array("worksheet1", "worksheet2", "worksheet3", "worksheet4")
  11.         Set ws = wbData.Worksheets(wsName)
  12.         lr = LastOccupiedRow(ws)
  13.         If lr > 1 Then    'any data from row 2 on?
  14.             ws.Range("A2:D" & lr).copy wb.Worksheets("sheet1").Cells(pasteRow, "A")
  15.             pasteRow = pasteRow + (lr - 1)
  16.         End If
  17.     Next wsName
  18.     
  19.     wbData.Close False
  20.     
  21. End Sub
  23. Function LastOccupiedRow(ws As Worksheet) As Long
  24.     Dim f As Range
  25.     Set f = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
  26.     If Not f Is Nothing Then LastOccupiedRow = f.Row
  27. End Function

huangapple
  • 本文由 发表于 2023年4月19日 22:06:32
  • 转载请务必保留本文链接：https://go.coder-hub.com/76055499.html
  • excel
  • vba
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定