怎样把A表保存到B表一样,请高师指教,谢谢!!!

徐海洋 · 发表于 2022-6-11 19:48

怎样把A表保存到B表一样,请高师指教,谢谢!!!

搜狗截图22年06月11日1940_1.png

去冒号转置.zip (10.28 KB, 下载次数: 4)

金樽空对月 · 发表于 2022-6-11 21:47

Sub mytranspose()
Dim x%, y%, i%, n%, dr
Dim ar, br(1 To 20000, 1 To 14), cr(1 To 1, 1 To 14)
With Sheets("表一")
x = .Range("a2").End(xlToRight).Column
y = .Range("a65536").End(3).Row
ar = .Range("a3").Resize(y - 2, x)
End With
For i = 1 To UBound(ar, 2)
For n = 1 To UBound(ar, 1)
dr = Split(ar(n, i), ":")
If i = 1 Then
cr(1, n) = dr(0)
br(i, n) = dr(1)
Else
br(i, n) = dr(1)
End If
Next n
Next i
With Sheets("表二")
.Range("a2").Resize(10000, 20) = ""
.Range("a2").Resize(1, 14) = cr
.Range("a65536").End(3).Offset(1, 0).Resize(UBound(br, 1), UBound(br, 2)) = br
.Activate
End With
End Sub

复制代码

hasyh2008 · 发表于 2022-6-11 22:22

本帖最后由 hasyh2008 于 2022-6-12 07:13 编辑

Sub tt()
Dim Arr, Brr, Crr(), Drr()
Dim X%, Y%, Rc%, Co%, T
T = Timer
With Sheet1
Rc = .Range("A1").CurrentRegion.Rows.Count
Co = .Range("A1").CurrentRegion.Columns.Count
Arr = .Range(.Cells(3, 1), .Cells(Rc, Co))
End With
Arr = Application.Transpose(Arr)
ReDim Crr(1 To UBound(Arr, 2))
ReDim Drr(1 To UBound(Arr), 1 To UBound(Arr, 2))
For X = 1 To UBound(Arr)
      For Y = 1 To UBound(Arr, 2)
         Brr = Split(Arr(X, Y), ":")
         If X = 1 Then
            Crr(Y) = Brr(0)
            Drr(X, Y) = Brr(1)
         Else
            Drr(X, Y) = Brr(1)
         End If
      Next Y
Next X
With Sheet2
      .Range("A1").CurrentRegion.Offset(1) = ""
      .Range("A2").Resize(1, UBound(Crr)) = Crr
      .Range("A3").Resize(UBound(Drr), UBound(Drr, 2)) = Drr
End With
MsgBox Format(Timer - T, "0.00")
End Sub

Sub 清除()
Sheet2.Range("A1").CurrentRegion.Offset(1) = ""
End Sub

徐海洋 · 发表于 2022-6-11 22:27

金樽空对月发表于 2022-6-11 21:47

谢谢高师 ,还是您文化高好啊,这么快就处理好了,谢谢,祝您及家人身体健康,万事如意,您辛苦了,谢谢

徐海洋 · 发表于 2022-6-11 22:39

hasyh2008 发表于 2022-6-11 22:22

谢谢恩师,谢谢您们百忙中替我们解疑难,有您们的指教,世界充满爱的阳光,普照中华大地,让我们感到爱与亲情的温暖,再次表深深的谢谢,给您们敬礼了,祝您们身体健康,寿比南山

		自动登录	找回密码
密码			注册