第2部分 - 将新数据解析为新表格（宏）

Question

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

我的excel工作表目前有两张

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

我知道这会很笨重。

我需要一个宏或按钮

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

总之，它应该看起来像这样 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

我在某种程度上坚持如何使其适应我的模板格式。

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

非常感谢

更新：我试过以下代码。创建模板的副本，并根据源中的值

重命名该模板

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

生成基于Excel列值的工作表

第2部分 - 将新数据解析为新表格（宏）

1 个答案: