求助拆分表格的代码

liqingwei123 · 发表于 2024-2-19 21:13

求助拆分表格的代码，感谢！！

miaojohn45 · 发表于 2024-2-19 21:16

发到这个区。

ykcbf1100 · 发表于 2024-2-19 22:19

附件供参考。。。

ykcbf1100 · 发表于 2024-2-19 22:19

参与一下。。。

Sub ykcbf() '//2024.2.19
Dim arr, brr, d
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tm: tm = Timer
Set ws = ThisWorkbook
Set sh = ws.Sheets("Sheet1")
For Each sht In Sheets
If sht.Name <> sh.Name Then
sht.Delete
End If
Next
arr = sh.[a1].CurrentRegion
For j = 2 To UBound(arr, 2)
s = Split(arr(1, j))(0)
d1(s) = ""
For i = 2 To UBound(arr)
s1 = arr(i, 1)
d2(s1) = s1
ss = s & "|" & arr(i, 1)
d(ss) = arr(i, j)
Next
Next
For Each k In d1.keys
Set sht = ws.Sheets.Add(after:=ws.Sheets(ws.Sheets.Count))
m = 0
ReDim brr(1 To UBound(arr), 1 To UBound(arr))
With sht
.Name = k
.[a1] = arr(1, 1): .[a2] = k
.[b1].Resize(1, d2.Count) = d2.keys
arr = .UsedRange
For i = 2 To UBound(arr)
For j = 2 To UBound(arr, 2)
s = arr(i, 1) & "|" & arr(1, j)
If d.exists(s) Then
arr(i, j) = d(s)
End If
Next
Next
With .UsedRange
.Value = arr
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.EntireColumn.AutoFit
End With
End With
Next k
sh.Activate
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "共用时：" & Format(Timer - tm) & "秒！"
End Sub

复制代码

Again123456 · 发表于 2024-2-20 09:12

function test(){
Application.DisplayAlerts = false
sht = ActiveSheet
for ( let sh of Sheets){
if (sh.Name != sht.Name) sh.Delete()
}
let arr = sht.Range("a1").CurrentRegion.Value2
let n = arr[0].length , c = arr.length
for(let i = 1 ; i < n ; i++ ){
let res = arr.map(v=> [v[0],v[i]])
let sh = Sheets.Add({After:Sheets(Sheets.Count)})
sh.Name = arr[0][i]
sh.Range("a1").Resize(c,2).Value2 = res
sh.UsedRange.Columns.AutoFit()
}
sht.Activate()
Application.DisplayAlerts = true
}

复制代码

求助.7z (8.06 KB, 下载次数: 2)

3190496160 · 发表于 2024-2-20 10:46

Sub 拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In Sheets
If sht.Index > 1 Then
      sht.Delete
End If
Next
Application.DisplayAlerts = True
Set sh = Sheets("Sheet1")
ar = sh.[a1].CurrentRegion
For j = 2 To UBound(ar, 2)
If ar(1, j) <> "" Then
      mc = Split(ar(1, j), " ")(0)
      sh.Copy after:=Sheets(Sheets.Count)
      With ActiveSheet
         .Name = mc
         For s = UBound(ar, 2) To 2 Step -1
            If s <> j Then
                  .Columns(s).Delete
            End If
         Next s
         For Each shp In .Shapes
            shp.Delete
         Next shp
      End With
End If
Next j
Application.ScreenUpdating = True
MsgBox "拆分完毕！"
End Sub

3190496160 · 发表于 2024-2-20 10:54

Sub 拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
w = MsgBox("拆分为工作表选是，拆分为工作簿选否", vbYesNoCancel)
If w = vbCancel Then End
If w = vbNo Then GoTo 10
For Each sht In Sheets
If sht.Index > 1 Then
      sht.Delete
End If
Next
Application.DisplayAlerts = True
10:
Set ws = ThisWorkbook
Set sh = ws.Sheets("Sheet1")
ar = sh.[a1].CurrentRegion
For j = 2 To UBound(ar, 2)
If ar(1, j) <> "" Then
      mc = Split(ar(1, j), " ")(0)
      If w = vbYes Then
         sh.Copy after:=Sheets(Sheets.Count)
         Set sht = ws.ActiveSheet
      Else
         sh.Copy
         Set wb = ActiveWorkbook
         Set sht = wb.ActiveSheet
      End If
      With sht
         .Name = mc
         For s = UBound(ar, 2) To 2 Step -1
            If s <> j Then
                  .Columns(s).Delete
            End If
         Next s
         For Each shp In .Shapes
            shp.Delete
         Next shp
      End With
      If w = vbNo Then wb.SaveAs Filename:=ThisWorkbook.Path & "\" & mc & ".xlsx": wb.Close
End If
Next j
Application.ScreenUpdating = True
MsgBox "拆分完毕！"
End Sub

3190496160 · 发表于 2024-2-20 10:56

自由选择拆分为工作簿还是工作表

求助.rar (22.79 KB, 下载次数: 10)

3190496160 · 发表于 2024-2-20 10:57

求助.rar (22.79 KB, 下载次数: 9)

3190496160 · 发表于 2024-2-20 10:58

可以自由选择拆分为工作簿还是工作表，供参考

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

[求助] 求助拆分表格的代码

评分

评分

评分