excel 筛选数据并将其复制到新工作表

pb3skfrl 于 2023-01-18 发布在其他

关注(0)|答案(1)|浏览(415)

我有一个关于病人健康数据的调查。我有一个表，上面有所有名为“数据”的数据，
这是数据表的外观，每列是患者的某个类别（有更多行）：

我正在创建一个宏，用户必须从下拉框中选择一个卫生机构，这将创建一个新工作表，命名为选定的卫生机构。分配给宏的按钮位于另一个名为“用户”的工作表上。
这是我的代码：编辑：我添加了子演示（）尝试粘贴它，但它没有工作。它说变量没有定义在部分“与表（sName）”

Option Explicit

Sub createsheet2()

   Dim sName As String, ws As Worksheet
   sName = Sheets("user").Range("M42").Value
   
   ' check if already exists
   On Error Resume Next
   Set ws = Sheets(sName)
   On Error GoTo 0
   
   If ws Is Nothing Then
       ' ok add
       Set ws = Sheets.Add(after:=Sheets(Sheets.Count))
       ws.Name = sName
       MsgBox "Sheet created : " & ws.Name, vbInformation
   Else
       ' exists
       MsgBox "Sheet '" & sName & "' already exists", vbCritical, "Error"
   End If
   
End Sub

Sub demo()

   Const COL_HA = 6 ' F

   Dim id As Long, rng As Range
   id = 20 ' get from user dropdown
   
   With Sheets("user")
       .AutoFilterMode = False
       .UsedRange.AutoFilter field:=COL_HA, Criteria1:=id
       Set rng = .UsedRange.SpecialCells(xlVisible)
   End With
   
   ' new sheet
'here is the problem
   With Sheets(sName)
      rng.Copy .Range("A1")
      .Range("A1").Activate
   End With

End Sub

我需要编写代码，在新工作表中只插入所选卫生机构的患者数据。每个卫生机构对应一个编号

“sha”列是用户之前选择的卫生当局。有人知道如何将我需要的数据插入到这个新创建的工作表中吗？
我想我需要先过滤数据，然后粘贴到工作表中。我对VBA很陌生，我迷路了。

excel

来源：https://stackoverflow.com/questions/75119983/filtering-data-and-copying-it-to-a-new-sheet

1条答案

按热度按时间

sd2nnvve1#

将您的代码替换为

Option Explicit

Sub createsheet()

    Const COL_HA = 6 ' F on data sheet is Health Auth

    Dim sName As String, sId As String
    Dim wsNew As Worksheet, wsUser As Worksheet
    Dim wsIndex As Worksheet, wsData As Worksheet
    Dim rngName As Range, rngCopy As Range
    
    With ThisWorkbook
         Set wsUser = .Sheets("user")
         Set wsData = .Sheets("data")
         Set wsIndex = .Sheets("index")
    End With
         
    ' find row in index table for name from drop down
    sName = Left(wsUser.Range("M42").Value, 30)
    Set rngName = wsIndex.Range("L5:L32").Find(sName)
    If rngName Is Nothing Then
        MsgBox "Could not find " & sName & " on index sheet", vbCritical
    Else
        sId = rngName.Offset(, -1) ' column to left
    End If
    
    ' create sheet but check if already exists
    On Error Resume Next
    Set wsNew = Sheets(sName)
    On Error GoTo 0
    
    If wsNew Is Nothing Then
        ' ok add
        Set wsNew = Sheets.Add(after:=Sheets(Sheets.Count))
        wsNew.Name = sName
        MsgBox "Sheet created : " & wsNew.Name, vbInformation
    Else
        ' exists
        MsgBox "Sheet '" & sName & "' already exists", vbCritical, "Error"
        Exit Sub
    End If
    
    ' filter sheet and copy data
    Dim lastrow As Long, rngData As Range
    With wsData
        lastrow = .Cells(.Rows.Count, COL_HA).End(xlUp).Row
        Set rngData = .Range("A10:Z" & lastrow)
        .AutoFilterMode = False
        rngData.AutoFilter Field:=COL_HA, Criteria1:=sId
        Set rngCopy = rngData.SpecialCells(xlVisible)
        .AutoFilterMode = False
    End With
   
    ' new sheet
    With wsNew
        rngCopy.Copy .Range("A1")
        .Range("A1").Activate
    End With
    
    MsgBox "Data for " & sId & " " & sName _
         & " copied to wsNew.name", vbInformation
   
End Sub

赞(0）回复(0）举报 2023-01-18

我来回答

excel 筛选数据并将其复制到新工作表

1条答案

相关问题

热门标签

最新问答