首先,我的源数据是这样的: SampleData
最终输出: Output for "AAM, PCM"
对于A列中的每个分支代码,我想将这些单元格(而不是整行)复制并移过另一个工作簿,然后将该工作簿保存为分支代码名称。 以下代码适用于复制和粘贴到同一工作簿中的新工作表,但我似乎无法修改它以满足我的需要。他们使用“调整大小”作为粘贴方法,我不熟悉
Sub columntosheets()
Const sname As String = "Sheet1" 'change to whatever starting sheet
Const s As String = "A" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
cc = .Columns(s).Column
End With
For Each sh In Worksheets
d(sh.Name) = 1
Next sh
Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
If a(i, 1) <> a(p, 1) Then
If d(a(p, 1)) <> 1 Then
Sheets.Add.Name = Left(a(p, 1), 25)
.Cells(1).Resize(, cls).Copy Cells(1)
.Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
End If
p = i
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate
End Sub
我尝试过其他一些方法,似乎无法正常工作。任何帮助将不胜感激!
以前的代码我曾经使用分支名称列表和SaveAs函数生成工作簿
For Each cell In MyRange
cell.Copy ws1.Range("I2").PasteSpecial ActiveWorkbook.SaveAs
Filename:="C:\Users\34389\Documents\test" & Range("I2").Value
Next cell