Question

我有一张名单和地址的主表：

Company Type        First   Last    TITLE           EMAIL           PHONE       US_MAIL_AD  US_MAIL_ADline2 CITY    STATE   ZIP
A       Telephone   Matt    Smith                   6789@def.com    265-3555    240 N       Indianapolis    IN      2222
B       Water       John    Cook    Design Engineer 12345@abc.com   265-3333    241 N       Indianapolis    IN      22222

我还有第二张包含电话日志模板的表格，其中包含地址等标题但不包含相同的行格式。

我希望excel为每个公司自动创建一个新工作表，我已经想到了（下面），但我需要新工作表来包含填充了地址信息的模板表中的标题。那么有没有办法在与创建工作表的函数相同的函数中复制特定单元格？

Public Function WorkSheetExists(SheetName As String, wrkbk As Workbook) As Boolean
    Dim wrkSht As Worksheet
    On Error Resume Next
        Set wrkSht = wrkbk.Worksheets(SheetName) 'Attempt to set reference to worksheet.
        WorkSheetExists = (Err.Number = 0) 'Was an error generated - True or False?
        Set wrkSht = Nothing
    On Error GoTo 0
End Function
Sub AddSheets()
    Dim MyCell As Range, MyRange As Range
    Dim wbToAddSheetsTo As Excel.Workbook
    Set MyRange = Sheets("Project Contact List").Range("B2")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))
    Set wbToAddSheetsTo = ActiveWorkbook
    For Each MyCell In MyRange
        If Not (WorkSheetExists(MyCell.Value, wbToAddSheetsTo)) Then
                Sheets.Add After:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = MyCell.Value
                On Error Resume Next
                ActiveSheet.Name = MyCell.Value
                'If Err.Number = 1004 Then
                '    Debug.Print cell.Value & " already used as a sheet name"
                'End If
                On Error GoTo 0
        End If
    Next MyCell
End Sub

Answer 1

不确定要传输哪些信息，但是这样的事情就可以了。

Sub AddSheets()

Dim MyCell As Range, MyRange As Range, ws As Worksheet
Dim wbToAddSheetsTo As Excel.Workbook

With Sheets("Project Contact List")
    Set MyRange = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
End With
Set wbToAddSheetsTo = ActiveWorkbook
For Each MyCell In MyRange
    If Not WorkSheetExists(MyCell.Value, wbToAddSheetsTo) Then
        Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
        ws.Name = MyCell.Value
        MyCell.Offset(, 1).Resize(, 9).Copy ws.Range("A1")
    End If
Next MyCell

End Sub

创建新工作表从单元格命名并使用主工作表

1 个答案: