求助 把工作簿里面的两个工作表拷贝到一个工作表中

bavinfeather

[tr] [/tr]
[tr] [/tr]
[tr] [/tr]
[tr] [/tr]

把附件工作簿里面的ProdList和ENGList的内容拷贝到SummarySheet工作表

SummarySheet工作表A-D列为公式   拷贝pordlist 其中A--G     B--I     C--E     D--F     E--J     F--L     G--K     H--H     I--M     K--N     R--P     拷贝ENGList  其中A--E     B--F     C--G     D--H     E--I     F--J     G--K     H--L     I--M     J--N     N--P     P--O

我的代码如下：
Application.ScreenUpdating = False
Dim fl

Dim strbook As Workbook

Dim sht As Worksheet

Dim arr

Dim i As Integer

Dim ii As Integer

Sheets("SummarySheet").Range("4:" & Rows.Count).Clear


Set strbook = ThisWorkbook

With ThisWorkbook.Sheets("SummarySheet")

For Each sht In strbook.Sheets

If sht.Name = "ProdList" Then

sht.Select

  i = sht.Range("A90000").End(xlUp).Row
  
  ii = .Range("A90000").End(xlUp).Row + 1
  
  sht.Range("A1:A" & i).Copy .Cells(ii, 7)
  
  sht.Range("B1:B" & i).Copy .Cells(ii, 9)

  sht.Range("C1:C" & i).Copy .Cells(ii, 5)

  sht.Range("D1:D" & i).Copy .Cells(ii, 6)

  sht.Range("E1:E" & i).Copy .Cells(ii, 10)

  sht.Range("F1:F" & i).Copy .Cells(ii, 12)

  sht.Range("G1:G" & i).Copy .Cells(ii, 11)

  sht.Range("H1:H" & i).Copy .Cells(ii, 8)

  sht.Range("I1:I" & i).Copy .Cells(ii, 13)
  
  sht.Range("K1:K" & i).Copy .Cells(ii, 14)
  sht.Range("R1:R" & i).Copy .Cells(ii, 16)

End If


If sht.Name = "ENGList" Then

sht.Select

  i = sht.Range("A90000").End(xlUp).Row
  
  ii = .Range("A90000").End(xlUp).Row + 1
  
  sht.Range("A2:A" & i).Copy .Cells(ii, 5)
  
  sht.Range("B2:B" & i).Copy .Cells(ii, 6)

  sht.Range("C2:C" & i).Copy .Cells(ii, 7)

  sht.Range("D2:D" & i).Copy .Cells(ii, 8)

  sht.Range("E2:E" & i).Copy .Cells(ii, 9)

  sht.Range("F2:F" & i).Copy .Cells(ii, 10)

  sht.Range("G2:G" & i).Copy .Cells(ii, 11)

  sht.Range("H2:H" & i).Copy .Cells(ii, 12)

  sht.Range("I2:I" & i).Copy .Cells(ii, 13)
  
  sht.Range("J2:J" & i).Copy .Cells(ii, 14)
  sht.Range("N2:N" & i).Copy .Cells(ii, 16)
  sht.Range("P2:P" & i).Copy .Cells(ii, 15)
End If

  
Next

End With

strbook.Close False

Calculate



End If
Worksheets("SummarySheet").UsedRange.ClearFormats
    Sheets("SummarySheet").Select
    With Selection
        .WrapText = False
    End With
Next



Application.ScreenUpdating = True
End Sub


但是无法运行。。。