Question

我目前有一个宏，它通过一个主表单解析，其中包含多个列表，并根据标签号将这些列表中的行复制到与该标签号对应的新表单。到目前为止，我已成功解析各种列表并执行此操作。

现在，我正在尝试将每个列表中的标题添加到要复制行的多个工作表中的每一个。在这方面，我无法添加到当前的宏，甚至找不到这个

的独立解决方案

换句话说，我试图从我的主表中的每个（多个）列表中抓取标题，然后将它们复制到我发送的数据行的表格中，这些表格对应于他们的标记＃。

下面是一个（令人讨厌的长）主表单示例以及我当前的宏，它解析整个表单并根据“Load＃”列对数据进行排序。

示例图片：http://imgur.com/9wqcBsX很抱歉链接，没有足够的代表发布图片:(

当前宏：

Option Explicit

Sub copyPaste_demo()
Dim rowCount, row_ix, temp, i As Integer
Dim TD_COL_IX As Integer
Dim td_value As String
Dim td_values() As String

    Application.ScreenUpdating = False

' #################
' Count rows starting in column A
' #################

    rowCount = Worksheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
' ########################
' starting row
' ########################
    For row_ix = 1 To rowCount

        temp = isNewTable(CInt(row_ix))
        If temp > 0 Then

            TD_COL_IX = temp

        ElseIf TD_COL_IX > 0 Then

            td_value = Worksheets("Master").Cells(row_ix, TD_COL_IX)
            If Not td_value = "" Then
                td_values = Split(td_value, " ")
                For i = 0 To UBound(td_values)

                    If Not sheetExists("Test Load " & td_values(i)) Then
                    ' #######
                    ' Adds new sheet for each unique identifier underneath 
      "LD   #"
                        Sheets.Add.Name = "Test Load " & td_values(i)
                    End If

                  ' Copy rows to be pasted 
########################################################################### 
TD_COL_IX -1 previously


                    If Worksheets("Test Load " & td_values(i)).Cells(1, 1).Value = "" Then

Worksheets("Master").Range(Worksheets("Master").Cells(row_ix, 1), 
Worksheets("Master").Cells(row_ix, TD_COL_IX)).Copy _
                            Destination:=Worksheets("Test Load " & td_values(i)).Cells(1, 1)
                    Else
                        Dim rowCount_pasteSheet As Integer
                        rowCount_pasteSheet = Worksheets("Test Load " & td_values(i)).Cells(Rows.Count, "A").End(xlUp).Row

                        ' Copy rows to be pasted 
########################################################################### 
TD_COL_IX -1 previously


Worksheets("Master").Range(Worksheets("Master").Cells(row_ix, 1), 
Worksheets("Master").Cells(row_ix, TD_COL_IX)).Copy _
                            Destination:=Worksheets("Test Load " & td_values(i)).Cells(rowCount_pasteSheet + 1, 1)
                    End If
                Next i
            End If
        End If
    Next row_ix

Application.ScreenUpdating = True
End Sub


Function isNewTable(row_ix As Integer) As Integer
Dim colCount, col_ix As Integer

    colCount = Worksheets("Master").Cells(row_ix, 
Columns.Count).End(xlToLeft).Column
    For col_ix = 1 To colCount

        If Not IsError(Worksheets("Master").Cells(row_ix, col_ix).Value) Then
            If Worksheets("Master").Cells(row_ix, col_ix).Value = "LD   #" Then
                isNewTable = col_ix
                Exit Function
            End If
        End If
    Next col_ix

    isNewTable = 0
End Function



' ####################################################
' sheetExists(sheetToFind As String) As Boolean
'
' Returns true if the sheet exists, False otherwise
' ####################################################
Public Function sheetExists(sheetToFind As String) As Boolean
    Dim sheet As Worksheet
    sheetExists = False
    For Each sheet In Worksheets
        If sheetToFind = sheet.Name Then
            sheetExists = True
            Exit Function
        End If
    Next sheet
End Function

Answer 1

如评论中所述：如果您能够自行访问所需数据，那么您可以使用Range.Offset属性轻松读出该数据上方的标题。

更新

此伪代码可防止循环内的重复

Dim headerCopied as Boolean
'for each sheet of data:
'loop for data within the sheet
If headercopied = False Then
'post your code here that you want to run only once per sheet
headerCopied = True
End If
'rest of your code
'next loop cycle

或者，您可以使用If语句检查其他内容，然后您将不需要布尔值。

解析包含多个列表的主表单并抓取每个列表的标题

1 个答案:

更新