☰

Excel 宏将 A 列中具有唯一名称的行复制到相应命名的工作表中

tag-icon • tag-icon microsoft-excel macros
Excel 宏将 A 列中具有唯一名称的行复制到相应命名的工作表中

我是 Excel 新手，希望得到有关执行以下操作的宏的帮助。

用户将数据粘贴到输入表中。

总共有 58 个基因（A 列），每个基因有 2 个条目。图像仅显示 4 个基因。

运行宏（通过快捷键）后，系统会提示用户输入样本编号（本例中为 Sample1），然后将每个基因的行复制粘贴到各自的工作表中（已创建）。所有基因均具有唯一名称。在每个基因工作表中，样本编号应填写在 A 列中。

基因1

我无法发布超过 2 张截图。其他基因的工作表应包含该基因的 2 行，A 列为“Sample1”。

一旦宏完成将行复制到 58 个表（针对 58 个基因）后，它应返回到输入表并删除之前粘贴的数据。应允许用户粘贴下一个样本的数据，运行宏，在提示时输入样本编号，然后该样本的基因数据将被复制到其各自基因表的下 2 行中。

有数千个样本的数据需要存入数据库，我希望得到一个能够做到这一点的宏。

编辑：现在的代码（感谢 Mrig）如下：

Sub Macro1()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim lastRow As Long, i As Long, currLastRow
    Dim ws As Worksheet, currWS As Worksheet
    Dim SampleID As String

    SampleIDform.Show

    Set ws = ThisWorkbook.Sheets("Input")
    lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

    For i = 2 To ThisWorkbook.Worksheets.Count
        Set currWS = ThisWorkbook.Sheets(i)
        currLastRow = currWS.Cells(Rows.Count, "A").End(xlUp).Row + 1
        With ws.Range("A1", "D" & lastRow)
            .AutoFilter Field:=1, Criteria1:=currWS.Name
            .Offset(1, 0).Copy currWS.Range("A" & currLastRow)
            .AutoFilter
            Range("A" & currLastRow).Value = SampleID
        End With
    Next i

    ws.Range("A2", "D" & lastRow).ClearContents

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Private Sub OkButton_Click()
    SampleID = txtSampleID.Value
    Unload Me
End Sub

我已将该行添加Range("A" & currLastRow).Value = SampleID到 with 循环中，但无法获取 A 列中每张工作表所包含的 SampleID。

我究竟做错了什么？

答案1

这应该可以满足您的要求：

假设：
1.输入表是您正在使用的工作簿中的第一个工作表
2.所有工作表都有标题Gene | Allele | Reads | Sequence

Sub DataToSheets()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Dim lastRow As Long, i As Long, currLastRow
    Dim ws As Worksheet, currWS As Worksheet

    Set ws = ThisWorkbook.Sheets("Input")
    lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

    For i = 2 To ThisWorkbook.Worksheets.Count
        Set currWS = ThisWorkbook.Sheets(i)
        currLastRow = currWS.Cells(Rows.Count, "A").End(xlUp).Row + 1
        With ws.Range("A1", "D" & lastRow)
            .AutoFilter Field:=1, Criteria1:=currWS.Name
            .Offset(1, 0).Copy currWS.Range("A" & currLastRow)
            .AutoFilter
        End With
    Next i

    ws.Range("A2", "D" & lastRow).ClearContents

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

对@user2140261 给出的答案做了一些更改关联@Sun 在评论中提到。

答案2

感谢 Mrig 的所有意见。我想我已经解决了我的问题。我的代码如下：

Sub DataToSheets()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim lastRow As Long, i As Long, currLastRow
    Dim ws As Worksheet, currWS As Worksheet
    Dim SampleID As String

    Set ws = ThisWorkbook.Sheets("Input")
    lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

    SampleID = InputBox("Key in Sample ID", "Sample ID")
    If (StrPtr(SampleID) = 0) Then
        MsgBox "You pressed cancel or [X]"
    ElseIf (SampleID = "") Then
        MsgBox "You did not enter anything"
    Else
    For i = 2 To ThisWorkbook.Worksheets.Count
        Set currWS = ThisWorkbook.Sheets(i)
        currLastRow = currWS.Cells(Rows.Count, "A").End(xlUp).Row + 1
        With ws.Range("A1", "D" & lastRow)
            .AutoFilter Field:=1, Criteria1:=currWS.Name
            .Offset(1, 0).Copy currWS.Range("A" & currLastRow)
            .AutoFilter
            currWS.Range("A" & currLastRow).Value = SampleID
            currWS.Range("A" & currLastRow + 1).Value = SampleID
        End With
    Next i
    End If
    ws.Range("A2", "D2" & lastRow).ClearContents

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub PasteValues()
'
' PasteValues Macro
'
' Keyboard Shortcut: Ctrl+r
'    
    On Error Resume Next

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

    Call DataToSheets

End Sub

由于某种原因，我无法识别用户表单的输入，因此只能使用 InputBox 方法来获取用户输入。行currWS.Range("A" & currLastRow).Value = SampleID和currWS.Range("A" & currLastRow + 1).Value = SampleID包括从输入表复制的 2 行 A 列中输入的 SampleID，适用于每个基因表。如果有更有效的方法，请告诉我。

用户所要做的就是复制数据，打开Excel文件，运行快捷键，然后在输入框中输入SampleID。

谢谢大家，特别是 Mrig！！

相关内容