扩展现有的复制粘贴循环：根据单元格值循环遍历特定列
Expand existing Copy-Paste Loop: Loop through specific Columns based on Cell Value
我目前有多个 excel spreadhsheet，如下所示：
table 是一份问卷，答案来自 C-F 列，C 是“最差”（字母 N），D 是“第二差”（字母 T），E 是第二好（字母 W） F 最好（Good 中的字母 G）。
这个 table 右边是我使用现有模块复制到另一个 Spreadsheet 的句子，具体取决于问卷中设置“x”的位置（它总是复制句子“x”右侧第 9 行。
现在我想修改我现有的代码，不仅要复制每一行的所有句子，而且每个作品只复制 5 个sheet。这 5 个应该是 5 个“最佳”答案（F 列中的 5 个，意思是问卷中的好答案，如果该列中的答案少于 5 个，则从 E 列中取出其余答案，直到你有 5 个）或 6 个“最差” " 答案，意思是 C 列中的 5 个（字母 N 表示不好），如果该列中的“X”少于 5 个，则从 D 列（字母 T）中取出其余部分。这样我想为每个作品复制 5 个最佳或最差的答案sheet。是否应复制最佳或最差答案的决定取决于每个作品中的一个简单单元格值（单元格 K6）sheet。 K6>70%选最佳答案，K6低于70%选最差答案
这是我当前的模块，用于复制我新作品的所有答案sheet:
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”，找到这些单元格并将值复制到新 sheet.
所以如果问卷看起来像这样：QuestionnaireOver70%
粘贴的 table 应如下所示：Table
如果调查问卷低于 70%，做同样的事情，但做最坏的（C 和 D 列，C 是最差的，如果 C 中没有 5 个“x”，则从 D 中取出其余的（第二个）最差))
希望对您有所帮助
编辑：包含我要从中复制的所有 sheet 的文件和当前模块：
https://www.dropbox.com/sh/wq8dgzmlpxgm76x/AACOG_SkE9WMqE22qvcd3tVBa?dl=0
编辑：已更新 link，excel 文件对所需步骤和工作进行了更多解释sheet以帮助理解（一个具有当前输出，一个具有所需输出）
阅读代码注释并根据您的需要进行调整
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
PS。我无法理解“Handlungsempfehlungen”中的输出，所以我留下了一个通用的
如果有效请告诉我
我目前有多个 excel spreadhsheet，如下所示：
table 是一份问卷，答案来自 C-F 列，C 是“最差”（字母 N），D 是“第二差”（字母 T），E 是第二好（字母 W） F 最好（Good 中的字母 G）。
这个 table 右边是我使用现有模块复制到另一个 Spreadsheet 的句子，具体取决于问卷中设置“x”的位置（它总是复制句子“x”右侧第 9 行。
现在我想修改我现有的代码，不仅要复制每一行的所有句子，而且每个作品只复制 5 个sheet。这 5 个应该是 5 个“最佳”答案（F 列中的 5 个，意思是问卷中的好答案，如果该列中的答案少于 5 个，则从 E 列中取出其余答案，直到你有 5 个）或 6 个“最差” " 答案，意思是 C 列中的 5 个（字母 N 表示不好），如果该列中的“X”少于 5 个，则从 D 列（字母 T）中取出其余部分。这样我想为每个作品复制 5 个最佳或最差的答案sheet。是否应复制最佳或最差答案的决定取决于每个作品中的一个简单单元格值（单元格 K6）sheet。 K6>70%选最佳答案，K6低于70%选最差答案
这是我当前的模块，用于复制我新作品的所有答案sheet:
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”，找到这些单元格并将值复制到新 sheet.
所以如果问卷看起来像这样：QuestionnaireOver70% 粘贴的 table 应如下所示：Table
如果调查问卷低于 70%，做同样的事情，但做最坏的（C 和 D 列，C 是最差的，如果 C 中没有 5 个“x”，则从 D 中取出其余的（第二个）最差))
希望对您有所帮助
编辑：包含我要从中复制的所有 sheet 的文件和当前模块： https://www.dropbox.com/sh/wq8dgzmlpxgm76x/AACOG_SkE9WMqE22qvcd3tVBa?dl=0
编辑：已更新 link，excel 文件对所需步骤和工作进行了更多解释sheet以帮助理解（一个具有当前输出，一个具有所需输出）
阅读代码注释并根据您的需要进行调整
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
PS。我无法理解“Handlungsempfehlungen”中的输出，所以我留下了一个通用的
如果有效请告诉我