Question

为了给出一些问题的背景，我正在尝试创建一个集中的主问答工作表，然后我会将问题分配给不同的人。提供给人们的电子表格只会显示分配给他们的问题。

例如，这将是未解决问题的初始主电子表格。

# Allocation Question Answer
1 A          ABC
2 A          DEF
3 B          GHI
4 A          JKL
5 C          MNO
6 B          PQR

但是，A人只会收到以下内容，并在将其发回以合并到主表之前填写答案栏。

# Allocation Question Answer
1 A          ABC
2 A          DEF
4 A          JKL

正如标题所示，我在尝试创建宏时遇到以下困难：

将整个表格作为值复制到每个指定答案的单独选项卡中（即一个名为A的选项卡，上面只有第二个表格，然后选项卡B和选项卡C等相同）。
一旦指定的答案填充了他们自己的工作表，他们就会将其发回，然后需要一个宏来填充主工作表，现在答案已填写

欣赏这似乎很多但很高兴知道是否有人之前做过这样的事情，如果有的话可以提供帮助吗？

提前多多谢谢。

AT

Answer 1

Sub MoveMasterData()

'Check each date
For Each Allocation In Worksheets("Master").Columns(2).Cells    'Change Master to your sheet name
    If Allocation.Value = "" Then Exit Sub 'Stop program if no data

    If Allocation.Row > 1 Then
        shtName = Allocation.Value    'Assign sheet name

        On Error GoTo errorhandler  'if no allocation Sheet, go to errorhandler to create new tab
        If Worksheets(shtName).Range("A2").Value = "" Then
           Allocation.EntireRow.Copy Destination:=Worksheets(shtName).Range("A2")
           Worksheets(shtName).Range("A1:D1").Columns.AutoFit
        Else
            Allocation.EntireRow.Copy Destination:=Worksheets(shtName).Range("A1").End(xlDown).Offset(1)
        End If
    End If
Next

Exit Sub
errorhandler:
Sheets.Add After:=Sheets(Sheets.Count) 'Create new tab
ActiveSheet.Name = shtName  'Name tab with Allocation
Worksheets("Master").Rows(1).EntireRow.Copy Destination:=ActiveSheet.Rows(1) 'Copy heading to new tab
Resume

End Sub

Sub CompileMaster()

'Check each Allocation
For Each Allocation In Worksheets("Master").Columns(2).Cells    'Change Master to your sheet name
    If Allocation.Value = "" Then Exit Sub 'Stop program if no data

    If Allocation.Row > 1 Then
        For Each sht In Worksheets
            If Allocation.Value = sht.Name Then
                For Each QNo In sht.Columns(1).Cells
                    If QNo.Value = "" Then Exit For 'Stop program if no data

                    RowQ = WorksheetFunction.Match(QNo, Worksheets("Master").Columns(1), 0) 'Check & Assign Question No
                    Worksheets("Master").Range("D" & RowQ).Value = QNo.Offset(0, 3).Value   'Transfer answer to master
                Next
            End If
        Next
    End If
Next

End Sub

2 Excel VBA宏：一个用于将数据从主工作表移动到单独的工作表中，另一个用于将更新的数据从单独的工作表移动到主工作表

1 个答案: