Question

我目前有多个 excel 电子表格，如下所示：

My Table

该表是一份问卷，其中包含 CF 列的答案，C 是“最差”（字母 N），D 是“次差”（字母 T），E 次佳（字母 W），F 是最好的（字母 N） G 为 Good））。

这张表的右边是我使用现有模块复制到另一个电子表格的句子，这取决于问卷中“x”的设置位置（它总是将句子复制到“x”右侧的 9 行).

现在我想修改我现有的代码，不仅复制每一行的所有句子，而且每个工作表只复制 5 个。这 5 个应该是 5 个“最佳”答案（F 列中的 5 个，意思是问卷中的答案很好，如果该列中的答案少于 5 个，则从 E 列中取出其余的答案，直到您有 5 个）或 6 个“最差” " 答案，意思是 C 列中的 5 个（字母 N 表示不好），如果该列中的“X”少于 5 个，则从 D 列（字母 T）中取其余的。这样我想为每个工作表复制 5 个最好或最差的答案。应复制最佳答案还是最差答案的决定取决于每个工作表中的一个简单单元格值（单元格 K6）。如果 K6 >70% 选择最佳答案，如果 K6 低于 70%，则选择最差答案。

这是我当前的模块，用于将所有答案复制到我的新工作表中：

Dim ws As Worksheet
Dim lr As Integer 'lastrow
Dim SpaltenIndex As Integer
Dim SheetNummer As Integer
Dim cl As Range 'cell
Dim rw As Range 'row
Dim Antwortrange As String
Dim WrkSht As Worksheet
Dim WrkShtCol As Sheets


'Create Destination Sheet
Sheets.Add
ActiveSheet.Name = "Handlungsempfehlungen"

'Set Questionnaire Answer Range to search through
Antwortrange = "C11:F400"

'ColumnIndex and SheetNumber
SpaltenIndex = 1
SheetNummer = 1

'Create Worksheet Collection with all the Questionnaire-Sheets
Set WrkShtCol = Worksheets(Array("AM AD - Anforderungsdefinition", "AM AA - Anforderunganalyse", "AM - Anforderungsdokumentation", "AM AV - Anforderungsvalidierung", "TM IT - Initiierung Test", "TM ZD - Zieldefinition", "TM TV - Testvorgehen", "TM TOB - Testobjektabgrenzung", "TM AS - Aufwandsschätzung", "TM TP - Testplanung", "TM TP - Testplanung", "TM TA - Testauftrag", "TM TS - Teststeuerung", "TM AO - Aufbauorganisation", "TM RM - Risikomanagement", "TM MI - Managementinformation", "TM AF - Abnahme Freigabe", "TM AT - Abschluss Test", "DT IT - Installationstest", "DT ST - Sicherheitstest", "OTP DT - Dokumententest", "OTP MT - Modultest", "OTP MIT - Modulintegrationstest", "OTP OO KT - OO Klassentest", "OTP OO KIT - OO Klassenintgrate", "OTP FT - Funktionstest", "OTP FIT - Funktionsintgratiotes", "OTP PIT - Produktintegratest", "OTP AT - Abnahmetest", "OTP ET - Ergonomietest", "OTP LPT - Last & Performance", "OTP GPT - Geschäftsprozesstest", "TUP TMK -Testumg Module Klassen", _
"TUP TUF - Testumgebung Funktion", "TUP TP - Testumgebung Prozesse", "ATP KM Konfigurationsmanagement", "ATP FAEM - Fehler Änderungs", "ATP DS - Datensicherheit", "ATP DSCH - Datenschutz", "ATP TEV -Testergebnisverwaltung", "ATP VG - Vertragsgestaltung"))
   
'MAIN LOOP: Take all sentences 9 rows to the right of each X in each Questionnaire and paste the value to the newly created sheet from above

For Each WrkSht In WrkShtCol

   For Each rw In WrkSht.Range(Antwortrange).Rows   
   For Each cl In rw.Cells
       
   lr = ws.Cells(ws.Rows.Count, SpaltenIndex).End(xlUp).Offset(1).Row
   If lr = 2 And ws.Range("A1") = "" And lr < 500 Then lr = 1
   'If lr = 2 And ws.Range("A2") = "" Then lr = 1
      
           If LCase(cl.Value) = "x" Then
               cl.Offset(0, 9).Copy Sheets("Handlungsempfehlungen").Cells(lr, SpaltenIndex)       
           End If
       Next cl
   Next rw



'If 1st row is empty in destination sheet, delete and shift rest up 
If Sheets("Handlungsempfehlungen").Cells(1, SpaltenIndex) = "" Then Sheets("Handlungsempfehlungen").Cells(1, SpaltenIndex).Delete Shift:=xlUp

'WrkShtCol(1).range("A2").Copy Worksheets("Handlungsempfehlungen").Cell(lr, SpaltenIndex)

Sheets("Handlungsempfehlungen").Cells(35, SpaltenIndex).Value = WrkShtCol(SheetNummer).Cells(2, 1)


SpaltenIndex = SpaltenIndex + 1
SheetNummer = SheetNummer + 1


End Sub

我希望你能帮助我，任何提示将不胜感激。在此先感谢您。

编辑 - 预期结果：

如果 K6 超过 70% - 找到 5 个最佳答案（第一优先级 F 列，如果 F 列中有 5 个“x”，则找到这些单元格并将值 9 行复制到新工作表的右侧。< /p>

所以如果问卷看起来像这样：QuestionnaireOver70% 粘贴的表格应如下所示：Table

如果问卷低于 70%，做同样的事情，但最坏的情况（C 列和 D，C 是最差的，如果 C 中没有 5 个“x”，那么从 D 中取出其余的（第二差） )

希望能帮到你

编辑：包含我要从中复制的所有工作表和当前模块的文件： https://www.dropbox.com/sh/wq8dgzmlpxgm76x/AACOG_SkE9WMqE22qvcd3tVBa?dl=0

编辑：更新链接，excel 文件有更多解释，包括所需的步骤和工作表以帮助理解（一个是当前输出，一个是所需输出）

Answer 1

阅读代码的注释并根据您的需要进行调整

Option Explicit

Public Sub DoSomething()

    ' Define the results sheet's name
    Dim resultsSheetName As String
    resultsSheetName = "Handlungsempfehlungen"
    
    ' Set the results sheet reference
    Dim resultsSheet As Worksheet
    Set resultsSheet = ThisWorkbook.Worksheets(resultsSheetName)

    ' Define the sheets to evaluate in an array
    Dim targetSheets As Sheets
    Set targetSheets = ThisWorkbook.Worksheets(Array("AM AD - Anforderungsdefinition", "AM AA - Anforderunganalyse", _
                        "AM - Anforderungsdokumentation", "AM AV - Anforderungsvalidierung", _
                        "TM IT - Initiierung Test", "TM ZD - Zieldefinition", _
                        "TM TV - Testvorgehen", "TM TOB - Testobjektabgrenzung", _
                        "TM AS - Aufwandsschätzung", "TM TP - Testplanung", _
                        "TM TP - Testplanung", "TM TA - Testauftrag", _
                        "TM TS - Teststeuerung", "TM AO - Aufbauorganisation", _
                        "TM RM - Risikomanagement", "TM MI - Managementinformation", _
                        "TM AF - Abnahme Freigabe", "TM AT - Abschluss Test", _
                        "DT IT - Installationstest", "DT ST - Sicherheitstest", _
                        "OTP DT - Dokumententest", "OTP MT - Modultest", _
                        "OTP MIT - Modulintegrationstest", "OTP OO KT - OO Klassentest", _
                        "OTP OO KIT - OO Klassenintgrate", "OTP FT - Funktionstest", _
                        "OTP FIT - Funktionsintgratiotes", "OTP PIT - Produktintegratest", _
                        "OTP AT - Abnahmetest", "OTP ET - Ergonomietest", _
                        "OTP LPT - Last & Performance", "OTP GPT - Geschäftsprozesstest", _
                        "TUP TMK -Testumg Module Klassen", "TUP TUF - Testumgebung Funktion", _
                        "TUP TP - Testumgebung Prozesse", "ATP KM Konfigurationsmanagement", _
                        "ATP FAEM - Fehler Änderungs", "ATP DS - Datensicherheit", _
                        "ATP DSCH - Datenschutz", "ATP TEV -Testergebnisverwaltung", _
                        "ATP VG - Vertragsgestaltung"))

    ' Loop through each sheet
    Dim targetSheet As Worksheet
    For Each targetSheet In targetSheets
        
        ' Get last row in target sheet
        Dim lastRow As Long
        lastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
        
        'targetSheet.Activate
        
        ' Remove any filters
        If targetSheet.FilterMode Then targetSheet.ShowAllData
        
        ' Set the range with X
        Dim rangeToFilter As Range
        Set rangeToFilter = targetSheet.Range("C7:F" & lastRow)
    
        ' Define a counter to check how many X there are
        Dim resultCounter As Long
        resultCounter = 1
        
        ' Check the grade (
        Dim gradeValue As Variant
        gradeValue = targetSheet.Range("K6").Value
        
        ' Check if the grade is not an error
        If Not IsError(gradeValue) Then
            
            ' Define the columns to filter (in order) according to the grade value
            Select Case gradeValue
            Case Is > 0.7
                    
                Dim columnsToFilter As Variant
                columnsToFilter = Array(4, 3) ' Columns F and E
                
            Case Else
                
                columnsToFilter = Array(1, 2) ' Columns C and D
                
            End Select
            
            ' Set a reference to the range that holds the Xs in first column
            Dim resultRange As Range
            Set resultRange = filterRange(rangeToFilter, columnsToFilter(0), "X")
            
            ' If there are any results in first column
            If Not resultRange Is Nothing Then
                ' Count them
                Dim countResult As Long
                countResult = resultRange.Count
                
                ' Get the results sheet's last row
                Dim resultsRow As Long
                resultsRow = resultsSheet.Cells(resultsSheet.Rows.Count, "A").End(xlUp).Row
                
                ' Print the results in results sheet
                printResults resultsSheet, resultsRow, resultRange, resultCounter
                
            End If

            ' If the results with Xs are less than five
            If resultCounter <= 5 Then
                ' Remove filters from sheet
                If targetSheet.FilterMode Then targetSheet.ShowAllData
                
                ' Set a reference to the range that holds the Xs in second column
                Set resultRange = filterRange(rangeToFilter, columnsToFilter(1), "X")
                
                ' If there are any results in second column
                If Not resultRange Is Nothing Then
                    
                    ' Print the results in results sheet
                    printResults resultsSheet, resultsRow, resultRange, resultCounter
                End If
            End If
            
        End If
        
    Next targetSheet

End Sub

Private Function filterRange(ByVal rangeToFilter As Range, ByVal fieldToFilter As Long, ByVal criteriaToFilter As String) As Range
    
    ' Apply auto filter in selected column
    rangeToFilter.AutoFilter Field:=fieldToFilter, Criteria1:=criteriaToFilter
    
    ' Use error handling to handle the case in which there aren't any results
    On Error Resume Next
    Set filterRange = rangeToFilter.Offset(1, 0).Columns(fieldToFilter).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
End Function

' In this sub is used the variable resultCounter ByRef which means that the value is passed back to the variable that is in the calling procedure
Private Sub printResults(ByVal resultsSheet As Worksheet, ByVal resultsRow As Long, ByVal resultRange As Range, ByRef resultCounter As Long)
    
    Dim targetCell As Range
    For Each targetCell In resultRange
        
        If resultCounter <= 5 Then
            resultsSheet.Range("A" & resultsRow + resultCounter).Resize(1, 3).Value = Array(resultRange.Parent.Name, resultCounter, targetCell.Offset(0, 9).Value)
        Else
            Exit For
        End If
        
        resultCounter = resultCounter + 1
        
    Next targetCell
    
End Sub

附注。我无法理解“Handlungsempfehlungen”中的输出，所以我留下了一个通用的

让我知道它是否有效

扩展现有的复制粘贴循环：根据单元格值循环特定列

1 个答案: