[已解决]将每个sheet中的数转置后合并汇总

我有一个excel，里边有多个sheet，
我想将每个sheet里的数据转置后再汇总到一个sheet中，用VBA该怎么做呢？
下面是一个示例

1. 这个Excel中有多个子sheet，每个子sheet有不同命名，sheet1为空，其余均有数据。
（ABC仅为示例，可能会有几百个子sheet）

2. 每个子sheet中的数据列的长度不一样
3.每个子sheet中的数据已全被选中
4.每个子sheet中的数据可能又空列（如SHEET C所示）
5.每个子sheet中的数据行数和列数可达到上百（图中仅为示例，所以只有几行几列）

6.最后希望把所有sheet中的数据 转置后汇总到sheet1 中（如上图所示）
7.不同sheet中转置黏贴过来的数据前面增加原sheet的名字作为标签。



我尝试这样，不行
Sub hong()
Application.ScreenUpdating = False
For j = 1 To Sheets.Count
   If Sheets(j).Name <> ActiveSheet.Name Then
    Sheets(j).Name.Range("A1").Select
      Sheets(j).Name.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Name.Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        End If
Next
Application.ScreenUpdating = True


跪求各位大神帮忙
End Sub

最佳答案

月排行榜 / 总排行榜

冥王

2015-4-7 23:41

1. Sub hong()
   
2.     Application.ScreenUpdating = False
   
3.     Dim j%, k%, rng As Range, rn As Range
   
4.     For j = 2 To Sheets.Count
   
5.         k = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
   
6.         Set rng = Sheets(1).Range("A65536").End(xlUp).Offset(1, 0)
   
7.         Set rn = Sheets(1).Range("A" & k)
   
8.         Sheets(j).UsedRange.Copy
   
9.         Sheets(1).Activate
   
10.         With Sheets("Sheet1")
    
11.             .Range("B" & k).PasteSpecial Transpose:=True
    
12.             n = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
    
13.             .Range("A" & k & ":A" & n) = Sheets(j).Name
    
14.         End With
    
15.     Next
    
16.     Application.ScreenUpdating = True
    
17. End Sub

复制代码

跳转到最佳答案楼层

冥王

1. Sub hong()
   
2.     Application.ScreenUpdating = False
   
3.     Dim j%, k%, rng As Range, rn As Range
   
4.     For j = 2 To Sheets.Count
   
5.         k = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
   
6.         Set rng = Sheets(1).Range("A65536").End(xlUp).Offset(1, 0)
   
7.         Set rn = Sheets(1).Range("A" & k)
   
8.         Sheets(j).UsedRange.Copy
   
9.         Sheets(1).Activate
   
10.         With Sheets("Sheet1")
    
11.             .Range("B" & k).PasteSpecial Transpose:=True
    
12.             n = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
    
13.             .Range("A" & k & ":A" & n) = Sheets(j).Name
    
14.         End With
    
15.     Next
    
16.     Application.ScreenUpdating = True
    
17. End Sub

复制代码

冥王 发表于 2015-4-7 23:41

厉害啊~！  大神 ~~~！！

但是这个代码有一个问题
如果我的空列在A列就出现了  它就会漏掉这个空列  我希望是所有的空列也能转置成空行
可以解决吗