Question

【50分求EXCEL高手】批量转置粘贴的问题！！宏，vba，公式~~都可以~~数据太多太疯了！！

sheet1里有大量的数据需要转置，简化之就是：

6000 1 2 4
6000 0 2 5
6000 3 3 3
6003 2 2 2
6003 2 3 5
6008 3 5 6
6008 3 2 3
6008 2 5 6

问题就是我需要把第一列相同数字的区域，比如6000这一列有三行，这三行我需要全部要转置粘贴到sheet2的区域，麻烦在于：1.第一列的数字不连续（6000，6003…）；2、同为6000的有三行，同为6003的有2行，也就是要粘贴的区域都是不一样的（不过列数是一样的，都是4列）；3、把6000粘好后要接着下面继续粘6003

大侠们~之前我已经求助过，有的给了公式，不过还是步骤挺多，我自己用筛选又特麻烦，好不容易看懂了宏，也只会简单的操作没大作用。恳请大家帮忙了~~不管是宏还是VBA还是公式都行~~~小女子先谢谢了！！！
转了以后就是

6000 6000 6000
1 0 3
2 2 3
4 5 3
6003 6003
2 2
2 3
2 5

Answer 1

你如果要 vba 的话 没有现成的 写起来也比较费时 ……给你个建议
思路是这样的：
你可以录制一个宏，这个宏只要把你共性的 操作 录制进去就好，然后你如果有能力写代码 就修改让他循环，没有的话，就增加一个按钮 你手工操作……知道完成……
录制过程如下：
1、先从你的当前表 最上方开始 选中若干行这样的数据（使用定位） 然后 剪切；
2、然后 转到下一张表中 找到第一行的第一个单元格 然后选择性粘贴 转置；
3、然后你再插入 与粘贴的行数 相同数量的空行
4、回到原表中，把刚刚剪切的那些行删掉
5、结束录制
剩下的你自己琢磨着办吧 这其中怎么 编排 你随意，主要是个思路……

追问

关键是不会VB代码~~宏也只会简单的···

追答

我刚才的叙述是 录制宏！你可以不写代码啊 这就是模拟你的操作……
你要做的只不过怎样操作 能够让这个录制的宏反复运行 都能进行你要的操作……
仔细看看吧，有些事情是要 尽量在自己力所能及的范围内 解决掉，我相信你一定可以的这样做 剩下的 就是怎么掌握 去修改一些代码，因为 你是 “批量” 就必须用到这些了……
方法 思路都说清楚了 剩下的就是 你去执行了……哈哈

Answer 2

使用这个宏就可以了
Sub 批量转置()
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:D10")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Cells(1, 1).Select
For j = 1 To 99
ActiveCell.Offset(1, 0).Select
If ActiveCell.Offset(-1, 0) = ActiveCell Then
i = i + 1
Else
Range(Cells(ActiveCell.Row - 1 - i, 1), Cells(ActiveCell.Row - 1, 4)).Copy
r = Sheets("Sheet2").Cells(1, 1).End(xlDown).Row + 1
If r >= 65535 Then
Sheets("Sheet2").Cells(1, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Else
Sheets("Sheet2").Cells(r, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End If
i = 0
End If
If ActiveCell.Offset(0, 0) = "" Then GoTo out
Next
out:

End Sub

Answer 3

先根据第一列sort一下，手工和宏都可以。然后用宏

思路是
用后一行第一列的值和上一行判断，如果相同就放在第二个sheet里面的同一行上，否则另取一行，列数加4并用常数保持这个数直到下一个不同。

我给你个框架，里面自己写吧。

sub run
i=2
do while not is empty cells(i,1)
...

end loop
end sub

Answer 4

Sub 转置()
Dim arr
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
With Sheets("sheet1")
ed = .[a65536].End(3).Row
For i = 1 To ed
arr = .Cells(i, 1).Resize(1, 4)
If Not dic1.exists(arr(1, 1)) Then
n = n + 1
dic1.Add arr(1, 1), n
dic2.Add arr(1, 1), 1
Else
dic2.Item(arr(1, 1)) = dic2.Item(arr(1, 1)) + 1
End If
r = dic1.Item(arr(1, 1)) * 4 - 3
c = dic2.Item(arr(1, 1))
Sheets("sheet2").Cells(r, c).Resize(4, 1) = _
Application.Transpose(arr)
Next
End With
End Sub

Answer 5

太难了，看不懂你的问题