对列进行迭代并在多个工作表中设置值

Question

我是个编程新手，所以请耐心点。

我目前有一个工作表，Sheet1 "DataSheet"，它在A、B和C列中未定义的行数量上保存字符串(文本)数据。Sheet2 "BlankSheet“是一个模板”记分卡“，我必须根据"DataSheet”中的数据输入总数无限期地复制它。我用命令按钮做了这件事。

Sub Button2_Click()
    Dim i As Long
    Dim xNumber As Integer
    Dim xName As String
    Dim xActiveSheet As Worksheet
    On Error Resume Next
    Application.ScreenUpdating = False
    Set xActiveSheet = ThisWorkbook.Worksheets("BlankSheet")
    xNumber = Range("J2")
    For i = 1 To xNumber
        xName = ActiveSheet.Name
        xActiveSheet.Copy after:=ActiveWorkbook.Sheets(xName)
        ActiveSheet.Name = "Individual Score Sheet" & i
    Next
    xActiveSheet.Activate
    Application.ScreenUpdating = True
    CommandButton1.Enabled = False
End Sub

通过创建适当数量的记分表，我需要将A、B和C列中的"DataSheet“中的个人数据导出到每个记分卡。

例：

1. "DataSheet“单元格A2需要转到”个人评分单元“范围A6:E6 (合并单元)，"DataSheet”单元B2到“个人分数Sheet1”范围F6:I6 (合并单元)，以及"DataSheet“单元C2到个人评分范围J6:N6 (合并单元)

1. "DataSheet“单元格A3需要转到”个人评分单元“范围A6:E6 (合并单元)，"DataSheet”单元B3到“个人分数Sheet2”范围F6:I6 (合并单元)，以及"DataSheet“单元C3到个人评分范围J6:N6 (合并单元)

等等等等。直到行是空的。

到目前为止，我已经：

Sub Button3_Click()

    Dim ws As Worksheet
    Application.ScreenUpdating = False
    
    With Sheet1
    
        For Each r In .Range("A1", .Range("A1").End(xlDown))
        
            For Each ws In Sheets
        
                Select Case ws.Name
                    Case "DataSheet", "BlankSheet"
                
                    Case Else

                    ws.Select
                    ws.Range("A6") = r
                
                End Select
                
            Next ws
                
        Next r
        
    End With

    Application.ScreenUpdating = True

End Sub

程序准确地忽略了"DataSheet“和"BlankSheet"，迭代A列中的数据并在没有数据时结束，并在其他工作表中迭代，但是它只将每个工作表的值设置为A列中数据的最后一次迭代。

我还没试着让B栏或C栏起作用。目标是自动生成"x“数量的”记分卡“打印。

当数据在A、B和C列中工作时，我如何重新处理它来将数据迭代到“个人得分Sheet#”工作表中？

可以将这两个按钮合并成一个命令吗？

提前感谢！

Answer 1

这段代码应该在一个子例程中完成所有操作，并且可以从一个单独的按钮中调用。

Option Explicit

Sub Button2_Click()
Dim wsData As Worksheet
Dim wsScore As Worksheet
Dim wsTemp As Worksheet
Dim rngSrc As Range
Dim idx As Long

    Application.ScreenUpdating = False
    
    Set wsData = ThisWorkbook.Sheets("DataSheet")
    Set rngSrc = wsData.Range("A2")
    
    Set wsTemp = ThisWorkbook.Worksheets("BlankSheet")
    
    Do
        wsTemp.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Set wsScore = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        idx = idx + 1
        With wsScore
            .Name = "Individual Score Sheet" & idx
            rngSrc.Copy .Range("A6:E6")
            rngSrc.Offset(, 1).Copy .Range("F6:I6")
            rngSrc.Offset(, 2).Copy .Range("J6:N6")
        End With
        
        Set rngSrc = rngSrc.Offset(1)
    Loop Until rngSrc.Value = ""
   
    Application.ScreenUpdating = True
    
    CommandButton1.Enabled = False
    
End Sub

Answer 2

从模板创建工作表

源设置

Datasheet

​

​

Blanksheet

​

​

结果

Individual Score Sheet1 to 3

​

​

标准模块，如

Option Explicit

Sub CopySheets()
    
    Const sName As String = "Datasheet"
    Const sFirst As String = "A2:C2"
    
    Const nName As String = "Blanksheet"
    
    Const dRangesList As String = "A6,F6,J6"
    Const dPattern As String = "Individual Score Sheet"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range
    Dim srCount As Long, scCount As Long
    With sws.Range(sFirst)
        Dim slCell As Range
        Set slCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If slCell Is Nothing Then Exit Sub
        scCount = .Columns.Count
        srCount = slCell.Row - .Row + 1
        Set srg = .Resize(srCount)
    End With
    
    Dim nws As Worksheet: Set nws = wb.Worksheets(nName)
    
    Dim dRanges() As String: dRanges = Split(dRangesList, ",")
    
    Application.ScreenUpdating = False
    
    Dim dws As Worksheet
    Dim srrg As Range
    Dim r As Long, c As Long
    Dim dSheetName As String
    
    For r = 1 To srCount
        Set srrg = srg.Rows(r)
        dSheetName = dPattern & r
        Application.DisplayAlerts = False
        DeleteExistingSheet wb, dSheetName
        Application.DisplayAlerts = True
        nws.Copy After:=wb.Sheets(wb.Sheets.Count)
        Set dws = ActiveSheet
        dws.Name = dSheetName
        For c = 1 To scCount
            dws.Range(dRanges(c - 1)).Value = srrg.Cells(c).Value
        Next c
    Next r
    
    Application.ScreenUpdating = True

End Sub

Sub DeleteExistingSheet( _
        ByVal wb As Workbook, _
        ByVal SheetName As String)
    On Error Resume Next
    Dim sh As Object: Set sh = wb.Sheets(SheetName)
    On Error GoTo 0
    If Not sh Is Nothing Then
        sh.Delete
    End If
End Sub

Datasheet Blanksheet或等工作表模块

Option Explicit

Private Sub CommandButton1_Click()
    CopySheets
End Sub