头痛了一天 请vba大牛小牛们都来帮帮忙：列首尾相连汇总 及 列+1的表示

shin711

一个问题发了两个区还没解决，这里是最后的希望了……
头痛了一天了，还请大家帮忙！！谢谢！！鞠躬~~

由表1：
地理 数学 语文
1      3      4
12    15    17
3      6      33
5              69
67
45

想要将每一列首尾相连成为新的一列，该怎么做？
实现如下效果

表2：
地理
1
12
3
5
67
45
数学
3
15
6
语文
4
17
33
69

如果可能的话 我的表1有多个sheet 想要全部放在表2的一个sheet里
不过我已经把表1的9个sheet拆分 手工合并也不太麻烦了
主要想求救如何把一个sheet里每一列首位相连成为一个新的列

其中，最头痛的就是从A列非空白的最后一行到B列第一行 的转换我不会 唉！！

[ 本帖最后由 shin711 于 2011-4-7 17:41 编辑 ]

dsmch

问题倒是不难，结果放在哪里？还有每列只有字段名，下面是空值的要不要罗列？
手工做个结果示意一下。

zhaogang1960

新加一个工作表，结果写到这个工作表：
Sub Macro1()
    Dim sh As Worksheet, arr, i&, m&, n&, j&
    For Each sh In Sheets
        If sh.Name <> ActiveSheet.Name Then
            n = n + 1
            arr = sh.[a1].CurrentRegion
            ReDim brr(1 To UBound(arr) * UBound(arr), 0)
            m = 0
            For j = 1 To UBound(arr, 2)
                For i = 1 To UBound(arr)
                    If Len(arr(i, j)) Then
                        m = m + 1
                        brr(m, 0) = arr(i, j)
                    End If
                Next
            Next
            Cells(1, n).Resize(m) = brr
        End If
    Next
End Sub

zhaogang1960

Vocabulary Classified.revised.rar (46.63 KB, 下载次数: 32)

2011-4-7 17:10 上传

点击文件名下载附件

愤怒的空调

都别抢，这个问题太简单了，我来回答，先占个座

愤怒的空调

我滴妈呀，我刷新了一下的功夫，3楼已经贴出解答了，拜服
这次又慢了，下次遇到简单问题跑快点。

fsyyyy

Sub Fsyyyy()
    For i = 2 To [a1].End(xlToRight).Column
        Cells(1, i).Resize(Cells(65536, i).End(xlUp).Row).Copy Destination:=[a65536].End(xlUp)(2)
    Next
'    [b1].Resize(65536, i - 2).Clear '清除原数据
End Sub

shin711

EH太帅了！！！
vba板块太帅了！！！

楼上的各位大虾们，你们都是热心的大好银！！！

zhaogang1960的代码很好用！！！！
fsyyyy的我再学习一下！！！！

学无止境，我用咆哮体向各位致敬！！！！！