复制/粘贴矢量链接到数据验证单元以获取所有验证值

Question

向量Worksheets("sheet1").Range("C2:C1000")的值与一个单元格Worksheets("sheet1").Range("A1")的值相关联-这是从范围Worksheets("List").Range("B1:xxxxx1")验证的数据Worksheets("List").Range("B1:xxxxx1") 。

我想为新Worksheets("sheet1").Range("A1")所有可能的值复制并粘贴列向量Worksheets("sheet1").Range("C2:C1000")的值。 最终结果应该是同一列“ N”次的表，其中N =数据验证值的计数，存储在Worksheets("sheet1").Range("A2") 。

编辑：根据注释的要求，在末尾添加了示例数据，以使其更加清晰

sub CopyBasedonDataValidation



'The loop will stop when there's no more data validated values in A1
For i = 1 To Worksheets("sheet1").Range("A2").Value



'First I am pasting the data validated values in A1 to change the column vector. 

 Worksheets("List").Range("A1").Offset(0, i).Copy
 Worksheets("sheet1").Range("A1").PasteSpecial Paste:=xlValues


'Then I am pasting the column vector into a new sheet. 

 Worksheets("sheet1").Range("C2:C1000").Copy
 Worksheets("newsheet").Range("A1").Offset(0, i).PasteSpecial Paste:=xlValues


Next i
End Sub

结果是一个表，其中包含n列，但所有列中的值均相同。 我假设数据验证单元格不会使用我的方法更改B列中的链接矢量。 有什么想法吗？

---

Worksheets("sheet1")

 "Loc1"          B1           C1
  N              Obs1         Good
                 Obs2         Good
                 Obs3         Bad
                 Obs4         VGood
                 ...          ...
                 Obs1000      Bad 

如果将A1更改为“ Loc2”，则C列更改

 "Loc2"          B1           C1
  N              Obs1         Avge
                 Obs2         Bad
                 Obs3         Avge
                 Obs4         Good
                 ...          ...
                 Obs1000      VBad 

如果A1变为“ Loc3”，则C列再次更改...

 "Loc3"          B1           C1
  N              Obs1         VBad
                 Obs2         VBad
                 Obs3         VGood
                 Obs4         Avge
                 ...          ...
                 Obs1000      Good

---

输出表：

           Loc1      Loc2      Loc3      Loc4      ...      LocN
Obs1       Good      Avge      VBad      Good      ...      VBad
Obs2       Good      Bad       VBad      VGood     ...      Avge
Obs3       Bad       Avge      VGood     Good      ...      VBad
Obs4       VGood     Good      Avge      Avge      ...      VBad 
...        ...       ...       ...       ...       ...      ...
Obs1000    Bad       VBad      Good      Good      ...      VBad 

此处B列将根据Worksheets("sheet1").Range("A1") （我可以在Worksheets("sheet2").Range("B1:xxxxx1")找到的Loc1到LocN的值进行更改Worksheets("sheet2").Range("B1:xxxxx1")

Answer 1

这是您要找的东西吗？

Sub CopyBasedonDataValidation()
    Application.EnableEvents = False: Application.ScreenUpdating = False
    On Error GoTo Cleanup
    Dim validCell As Range, targetCol As Range
    With Worksheets.Add
        .Name = "ValidationSheet"
        .Columns("A").Value = Worksheets("sheet1").Columns("B").Value
        Set targetCol = .Columns("B")
    End With

    With Worksheets("sheet1")
        'We fetch the data from the validation list
        For Each validCell In Application.Range(.Range("A2").Validation.Formula1)
            .Range("A1").Value = validCell.Value
            .Calculate
            targetCol.Value = .Columns("C").Value
            targetCol.Cells(1).Value = validCell.Value
            Set targetCol = targetCol.Offset(, 1)
        Next
    End With
Cleanup:
    If Err.Number <> 0 Then MsgBox Err.Description
    Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

Answer 2

如果我对您的理解正确，那么类似的事情应该可以帮助您：

sub CopyBasedonDataValidation

    dim lngLastCol  as long 

    'The loop will stop when there's no more data validated values in A1
    'First I am pasting the data validated values in A1 to change the column vector.        
    lngLastCol = lastColumn("sheet1")+1

     Worksheets("List").Columns(i).Copy
     Worksheets("sheet1").Columns(lngLastCol).pastespecial Paste:= xlvalues
End Sub


Function last_column(Optional str_sheet As String, Optional row_to_check As Long = 1) As Long

    Dim shSheet  As Worksheet

    If str_sheet = vbNullString Then
        Set shSheet = ActiveSheet
    Else
        Set shSheet = Worksheets(str_sheet)
    End If

    last_column = shSheet.Cells(row_to_check, shSheet.Columns.Count).End(xlToLeft).Column
End Function

代码进入工作表List并复制第二列。 然后将其添加到Sheet1的最后一列之后。

Answer 3

您可以尝试以下方法：

Option Explicit

Sub CopyBasedonDataValidation()
    Dim dataRng As Range, validCell As Range, validRng As Range, cell As Range

    With Worksheets("sheet1") '<--| reference "sheet1"
        Set validCell = .Range("A1") '<--| set the range where to change validation values
        Set dataRng = .Range("c2", .Cells(.Rows.Count, "C").End(xlUp)) '<--| set validation cell i.e.: the range where data changes
    End With

    With Worksheets("sheet2")  '<--| reference "sheet2"
        Set validRng = .Range("B1", .Cells(1, .Columns.Count).End(xlToLeft)).SpecialCells(xlCellTypeConstants) '<--| set the range with not blank validation values
    End With

    With Worksheets("newsheet") '<--| reference "newsheet"
        Application.Calculation = xlCalculationManual '<--| prevent calculation before writing to referenced sheet
        .Range("A2").Resize(dataRng.Rows.Count).Value = dataRng.Offset(, -1).Value '<--| write rows "headers"
        For Each cell In validRng '<--| loop through validation range
            Application.Calculation = xlCalculationAutomatic '<--| restore calculation
            validCell.Value = cell.Value '<--| change validation cell to current validation value
            Application.Calculation = xlCalculationManual '<--| prevent calculation before writing to referenced sheet
            With .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) '<-- reference currently "free" column
                .Value = cell.Value '<--| write current validation value
                .Offset(1).Resize(dataRng.Rows.Count).Value = dataRng.Value '<--| write corresponding calculated values
            End With
        Next
    End With
End Sub