Excel VBA将列表复制到新工作表

我在Excel中有一个包含城市、地址和姓名的人员详细信息的列表

我需要抓取City列并为每个城市创建一个工作表，然后将数据从sheet1复制到新的工作表中

例如，如果我有一个名为都柏林的城市，我需要宏来创建一个名为都柏林的新工作表，转到列表，抓取所有名为都柏林的城市，复制并粘贴到都柏林工作表中（当然还有其他列）

我正在使用宏表单链接：由mirabeau创建

代码如下：

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 = a(p, 1)
                .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

子列ToSheets（）
Const sname As String=“Sheet1”更改为任何起始页
Const s As String=“A”更改为任意条件列
尺寸d作为对象，a，cc&
尺寸p＆i＆rws＆cls&
Set d=CreateObject（“scripting.dictionary”）
带床单（sname）
rws=.Cells.Find（“*”，xlByRows，xlPrevious）.Row
cls=.Cells.Find（“*”，xlByColumns，xlPrevious）.Column
cc=.Columns（s）.Column
以
对于工作表中的每个sh
d（sh.Name）=1
下一个sh
Application.ScreenUpdating=False
使用Sheets.Add（之后：=Sheets（sname））
工作表（sname）.单元格（1）.调整大小（rws，cls）.复制.单元格（1）
.Cells（1）.调整大小（rws，cls）.排序.单元格（cc），2，标题：=xlYes
a=.Cells（cc）.Resize（rws+1,1）
p=2
对于i=2至rws+1
如果a（i，1）a（p，1），那么
如果d（a（p，1））1那么
Sheets.Add.Name=a（p，1）
.单元格（1）.调整大小（，cls）.复制单元格（1）
.单元格（p，1）.调整大小（i-p，cls）.复制单元格（2，1）
如果结束
p=i
如果结束
接下来我
Application.DisplayAlerts=False
删去
Application.DisplayAlerts=True
Application.ScreenUpdating=True
以
工作表（sname）。激活
端接头

---

上述功能可以为每个城市创建工作表，但不会将数据复制到新创建的工作表中。如何做到这一点？我对VBA的了解非常有限，对此我完全不知所措。

一旦创建了所有表格，您只需在列表中搜索城市即可。对于每一行，查看城市，并将其写在相应的表格中。工作表需要与城市名称相同，我的代码才能工作

我想您是从A列第1行开始的

dim strCity as string
dim strAdd as string
dim strName as string
for i = 1 to Sheets("[TableSheet]").Cells(Rows.Count, "A").End(xlUp).row
     strCity = Sheets("[TableSheet]").range("A" & i)
     strAdd = Sheets("[TableSheet]").range("B" & i)
     strName = Sheets("[TableSheet]").range("C" & i)

     Sheets(strCity).Range("A" & i) = strCity
     Sheets(strCity).Range("B" & i) = strAdd
     Sheets(strCity).Range("C" & i) = strName
next

---

[表页]当然是包含您信息的表页的名称。如果您不理解并且有问题，我很乐意回答。

谢谢您的快速回复。我在一个简单的列表中使用了它，效果很好。但是，我将其应用于稍微复杂的场景，并对代码进行了如下编辑：

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 = a(p, 1)
                .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

Dim strDB作为字符串
将strName设置为字符串
作为字符串的Dim strDate
暗弦
作为字符串的Dim strMin
作为字符串的Dim strGR
对于i=1到工作表（“[TableSheet]”）。单元格（Rows.Count，“B”）。结束（xlUp）。行
strDB=工作表（“[表表]”）。范围（“A”&i）
strName=Sheets（“[TableSheet]”）。范围（“B”和“i”）
标准日期=工作表（“[表表]”）。范围（“C”&i）
strHour=Sheets（“[TableSheet]”）。范围（“D”和“i”）
strMin=Sheets（“[TableSheet]”）。范围（“E”和“i”）
strGR=工作表（“[表表]”）。范围（“F”&i）
图纸（标准名称）。范围（“A”和i）=标准数据库
图纸（标准名称）。范围（“B”和i）=标准名称
图纸（标准名称）。范围（“C”和i）=标准日期
图纸（标准名称）。范围（“D”和i）=标准尺寸
图纸（标准名称）。范围（“E”&i）=标准名称
图纸（strName）。范围（“F”和i）=strGR
接下来

您是否尝试过复制工作表，按城市排序，然后按顺序删除不需要的内容？这样你就不用担心复制任何东西了。嘿，大卫！谢谢你的回复，我遇到了下面发布的运行时错误，有什么提示吗？抱歉，如果我问了一些愚蠢的问题，但我正试图用我有限的知识简化一些工作中非常繁忙的任务。循环可能走得太远了。可能为strName指定了一个空值，这会导致工作表（strName）崩溃。如果您尝试使用i=1到Sheets（“[TableSheet]”）。Cells（Rows.Count，“B”）。End（xlUp）。Row-1，它工作吗？它对最后一个值有效还是跳过一个？如果没有，我建议在代码的末尾添加一个，看看它在哪里。干杯