生成基于工作表的 Excel 列值

Question

我不是 excel vba 方面的专家，但需要帮助。

我目前有一张 excel 工作表，里面有两张表

1. “数据”表：我所有的data (click to see) 长列表都在这里。
2. “模板”表。我创建了一个template (click to see) 来格式化我的数据

我知道这会很笨重。

我需要一个宏或按钮

1. 可以根据上面的模板为“数据”表中A列值的每一行创建一个新表
2. 新工作表的名称将取自“数据”工作表中的 A 列值
3. 复制数据后，新工作表应保留模板的格式

总而言之，它应该看起来像这样 this (click to see) 用于数据表 A 列中的第一行 和this (click to see) 用于数据表 A 列中的第二行。 这是上传的工作表示例 https://ufile.io/bxwo6

我实际上尝试了以下方法

http://sites.madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/sheet1-to-sheets

第 2 部分 - 将新数据解析到新工作表（宏）

它完成了获取每一行并将其分成不同工作表的工作。结果是 This is my Data sheet This is the result of the split which is good

我不知如何让它适应我的模板格式。

如果您能提供任何我可以尝试的提示、帮助或建议，我将不胜感激

非常感谢

更新： 我已经尝试了以下代码。创建模板的副本并根据源中 A 列中的值对其进行重命名

Sub AutoAddSheet()

    Dim MyCell As Range, MyRange As Range

    Set MyRange = Sheets("Datas").Range("A1")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))

    For Each MyCell In MyRange
        Sheets("TEMPLATE").Copy After:=Sheets(Sheets.Count) 'Create a new worksheet as a copy of Sheet number 9 in this example
        Sheets(Sheets.Count).Name = MyCell.Value 'Renames the new worksheets
    Next MyCell
End Sub

更新 2：这是我从上面的链接修改的代码。请注意，我们不能使用列“：”值重命名工作表，因此，我修改了我的源，将其从 1:1 更改为 1，将 1:2 更改为 2

Option Explicit
Sub ParseItems()

    Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long, NR As Long
    Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long, Append As Boolean

    Application.ScreenUpdating = False

    'Column to evaluate from, column A = 1, B = 2, etc.
       vCol = 1
     
    'Sheet with data in it
       Set ws = Sheets("Data")

    'option to append new data below old data
    If MsgBox(" If sheet exists already, add new data to the bottom?" & vbLf & _
               "(if no, new data will replace old data)", _
               vbYesNo, "Append new Data?") = vbYes Then Append = True
    'Range where titles are across top of data, as string, data MUST
    'have titles in this row, edit to suit your titles locale
        vTitles = "A1:Z1"
        TitleRow = Range(vTitles).Cells(1).Row

    'Spot bottom row of data
       LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

    'Get a temporary list of unique values from vCol
        iCol = ws.Columns.Count
        ws.Cells(1, iCol) = "key"
        
        For Itm = TitleRow + 1 To LR
            On Error Resume Next
            If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
                .Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
                   ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
            End If
        Next Itm
    'Sort the temporary list
        ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

    'Put list into an array for looping
        MyArr = Application.WorksheetFunction.Transpose _
            (ws.Columns(iCol).SpecialCells(xlCellTypeConstants))

    'clear temporary list
        ws.Columns(iCol).Clear

    'Turn on the autofilter
        ws.Range(vTitles).AutoFilter

    'Loop through list one value at a time
    'The array includes the title cell, so we start at the second value in the array
        For Itm = 2 To UBound(MyArr)
            ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=CStr(MyArr(Itm))
        
            If Not Evaluate("=ISREF('" & CStr(MyArr(Itm)) & "'!A1)") Then   'create sheet if needed
                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(MyArr(Itm))
                NR = 1
            Else                                                            'if it exists already
                Sheets(CStr(MyArr(Itm))).Move After:=Sheets(Sheets.Count)   'ordering the sheets
                If Append Then                                              'find next empty row
                    NR = Sheets(CStr(MyArr(Itm))).Cells(Rows.Count, vCol).End(xlUp).Row + 1
                Else
                    Sheets(CStr(MyArr(Itm))).Cells.Clear                    'clear data if not appending
                    NR = 1
                End If
            End If
        
            If NR = 1 Then                                                  'copy titles and data
                ws.Range("A" & TitleRow & ":A" & LR).EntireRow.Copy Sheets(CStr(MyArr(Itm))).Range("A" & NR)
            Else                                                            'copy data only
                ws.Range("A" & TitleRow + 1 & ":A" & LR).EntireRow.Copy Sheets(CStr(MyArr(Itm))).Range("A" & NR)
            End If
            
            ws.Range(vTitles).AutoFilter Field:=vCol                        'reset the autofilter
            If Append And NR > 1 Then NR = NR - 1
            MyCount = MyCount + Sheets(CStr(MyArr(Itm))).Range("A" & Rows.Count).End(xlUp).Row - NR
            Sheets(CStr(MyArr(Itm))).Columns.AutoFit
        Next Itm
        
    'Cleanup
        ws.Activate
        ws.AutoFilterMode = False
        MsgBox "Rows with data: " & (LR - TitleRow) & vbLf & "Rows copied to other sheets: " _
                    & MyCount & vbLf & "Hope they match!!"

        Application.ScreenUpdating = True
End Sub

Answer 1

这应该给你一个可以开始的想法。它循环遍历数据，并为每个数据行复制模板、重命名模板并将数据行填充到特定范围内。

Option Explicit

Public Sub AutoParseItems()
    Dim wsData As Worksheet
    Set wsData = ThisWorkbook.Worksheets("Datas")

    Dim lRow As Long
    lRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row 'find last row in column A

    Const fRow As Long = 1 'set first data row

    Dim iRow As Long
    For iRow = fRow To lRow 'loop throug data rows
        'create a copy of the sheet
        ThisWorkbook.Worksheets("TEMPLATE").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Dim wsNewTemplateCopy As Worksheet
        Set wsNewTemplateCopy = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

        'determine new sheet name and rename the sheet
        With wsData.Cells(iRow, "A")
            wsNewTemplateCopy.Name = Right$(.Text, Len(.Text) - InStr(1, .Text, ":"))   'find : to determine new sheet name
        End With

        'fill in the text into the new sheet
        wsNewTemplateCopy.Range("A1").Value = wsData.Cells(iRow, "A").Value
        wsNewTemplateCopy.Range("A5").Value = wsData.Cells(iRow, "C").Value
        wsNewTemplateCopy.Range("A22").Value = wsData.Cells(iRow, "D").Value
            'modify the ranges where you need your data
    Next iRow
End Sub