Question

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

我想在新列中为Worksheets("sheet1").Range("C2:C1000")的所有可能值复制并粘贴列向量Worksheets("sheet1").Range("A1")的值。最终结果应该是同一列“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）的值进行更改

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

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

3 个答案: