将列表中的项目附加到新列表（MS Excel）

Question

感谢大家帮助我早些时候query。我把我的下一个障碍作为一个单独的线程包括在内，希望不违反任何规则/礼仪。

我现在有一个搜索工具，可以创建潜在相关诊断的列表：

我希望能够做的是在可能相关的诊断列表中进行操作，并通过放置＆＃34; x＆＃34;来手动删除那些不相关的诊断。在相邻的细胞中。然后，我想按一个按钮，并将所有已检查的诊断附加到另一张纸上的列表中（标题为＆＃34; List＆＃34;）：

在理想的世界中，重复搜索/选择/按钮过程然后只需将新诊断添加到同一列表中，即识别＆＃34;列表中的下一个空白单元格。并从那里继续。一个潜在的困难是我需要从每个单元格中复制诊断文本，而不是实际存在的公式。

Gary的学生之前用这个剧本回答了类似的query但是它并没有让我足够远，因为它从单个单元格中获取数据并且没有区分文本/公式：

Sub ButtonCode()
   Dim N As Long
   N = Cells(Rows.Count, "A").End(xlUp).Row + 1
   Cells(N, "A").Value = Range("C3").Value
End Sub

有人可以帮忙吗？

Answer 1

您可能想尝试以下提供的内容。请注意，您可以抓住所有＆＃39; x＆＃39;指定的单元格。使用.Offset属性进行复选标记。代码如下：

Sub move_diagnoses()
Dim diagnosesheet As Worksheet
Dim copysheet As Worksheet
Dim last_diagnosis_row As Integer
Dim last_list_row As Integer
Dim loserange As Range
Dim losecell As Range

'Set your worksheets first
Set diagnosesheet = Worksheets("Diagnoses")
'I titled the worksheet you have the diagnoses on as 'Diagnoses' since you didn't specify
Set copysheet = Worksheets("List")

'Now set the range (i.e. collection of cells) that enumerate all the potential diagnoses
'First find the last row in the diagnoses column
'Then find the last used row in the 'List' worksheet
last_diagnosis_row = diagnosesheet.Range("E" & Rows.Count).End(xlUp).Row
last_list_row = diagnosesheet.Range("A" & Rows.Count).End(xlUp).Row
Set loserange = diagnosesheet.Range("D2:D" & last_diagnosis_row)
'Notice the loserange (i.e. the range that contains the all the checkmarks is defined from D2 onwards

For Each losecell In loserange.Cells
    If Trim(losecell.Value) = "x" Then
        copysheet.Cells(last_list_row, 1).Value = losecell.Offset(0, 1).Text
        copysheet.Cells(last_list_row, 2).Value = losecell.Offset(0, 2).Text
        last_list_row = last_list_row + 1
    End If
Next losecell


End Sub