[已解决]不同sheet同一位置的数据归类到最后一个sheet的同一行中

陌雨落0724

想把同一工作簿的不同sheet的A8单元格数据，都放到这个工作簿最后一个空白sheet的第一行，用vba循环怎么做？

最佳答案

月排行榜 / 总排行榜

chart888

2017-7-13 17:31

1. Private Sub CommandButton1_Click()
   
2. Dim sht, irow&
   
3. Application.ScreenUpdating = False
   
4. Worksheets(1).Activate
   
5.     irow = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
   
6.     If irow > 1 Then irow = irow + 1
   
7.     For Each sht In Worksheets
   
8.         If sht.Name <> Worksheets(1).Name Then
   
9.             With sht
   
10.                 irow = irow + 1
    
11.                 .Range("a8:a8").Copy Range("a" & irow)
    
12.                 .Range("d6:d6").Copy Range("b" & irow)
    
13.                 .Range("e6:e6").Copy Range("c" & irow)
    
14.             End With
    
15.         End If
    
16.     Next
    
17. Application.ScreenUpdating = True
    
18. End Sub

复制代码

跳转到最佳答案楼层

chart888

最后一个空白的sheet是本来就存在的还是会汇总的时候新建的？
放在第一行，每一个sheet的单独放在一个单元格吗？

陌雨落0724

chart888 发表于 2017-7-13 16:18
最后一个空白的sheet是本来就存在的还是会汇总的时候新建的？
放在第一行，每一个sheet的单独放在一个单元 ...

对的。我现有的代码是这样子的。但是得到的第一列数据顺序是乱的；第二列第三列缺少第一个sheet的数据该怎么办。
Sub 复制数据()
Dim sht, irow&
Application.ScreenUpdating = False
Worksheets(1).Activate
  irow = Cells(Rows.Count, 1).End(xlUp).Row
  If irow > 1 Then irow = irow + 1
  For Each sht In Worksheets
   If sht.Name <> Worksheets(1).Name Then
    With sht
     .Range("a8:a8").Copy Range("a" & irow)
      irow = Cells(Rows.Count, 1).End(xlUp).Row + 1
     .Range("d6:d6").Copy Range("b" & irow)
      irow = Cells(Rows.Count, 1).End(xlUp).Row + 1
     .Range("e6:e6").Copy Range("c" & irow)
      irow = Cells(Rows.Count, 1).End(xlUp).Row + 1
    End With
   End If
  Next
Application.ScreenUpdating = True
End Sub

chart888

1. Private Sub CommandButton1_Click()
   
2. Dim sht, irow&
   
3. Application.ScreenUpdating = False
   
4. Worksheets(1).Activate
   
5.     irow = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
   
6.     If irow > 1 Then irow = irow + 1
   
7.     For Each sht In Worksheets
   
8.         If sht.Name <> Worksheets(1).Name Then
   
9.             With sht
   
10.                 irow = irow + 1
    
11.                 .Range("a8:a8").Copy Range("a" & irow)
    
12.                 .Range("d6:d6").Copy Range("b" & irow)
    
13.                 .Range("e6:e6").Copy Range("c" & irow)
    
14.             End With
    
15.         End If
    
16.     Next
    
17. Application.ScreenUpdating = True
    
18. End Sub

复制代码