Pasting specific data on a new sheet with macro-CodePudding

I have a hospital spreadsheet with data, where the data is organised depending on age, sex, Health Authority etc. Like this:

Where "sha" means the Health Authority, and each number corresponds to a certain one. 1-Norfolk, Suffolk and Cambridgeshire 2-Bedforshire & Hertfordshire and so on until Health Authority number 28

I am creating a macro that opens a new sheet, and I need to only paste the data of the patients from a certain Health authority previously selected from a drop-down box.

I have already created the macro that creates the new sheet (i'll paste the code here), but now I need to paste all the data of the patients only if they belong to the health authority selected from the drop-down box. This is my code so far:

Option Explicit

Sub createsheet()

   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

CodePudding user response：

You can call this sub from your sub like:
Transfer_to_NewSheet ws, SHA
Where SHA is the SHA number from whatever drop down you're using.
I'm sure you can figure out how to do that.

Also remember to change:
Set Master = Worksheets("Main")
to whatever your data sheet is called.

Sub Transfer_to_NewSheet(WS As Worksheet, SHA)

    Dim Master As Worksheet
    Dim DataRG As Range
    Dim InArray
    Dim OutArray
    Dim I As Long
    Dim Y As Long
    Dim X As Long
    Dim W As Long
    Dim lRow As Long
    Dim lCol As Long
    Dim SHAcol As Long

    ' Or whatever your master sheet is called
    Set Master = Worksheets("Main")
    
    With Master
        lCol = .Range("ZZ1").End(xlToLeft).Column
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
        SHAcol = .Range("A1").Resize(1, lCol).Find(What:="sha", LookIn:=xlValues, LookAt:=xlWhole).Column
        Set DataRG = .Range("A1").Resize(lRow, lCol)
    End With
    
    InArray = DataRG
    ReDim OutArray(1 To lRow, 1 To lCol)
    
    Y = 1
    For I = 1 To UBound(InArray, 1)
        If InArray(I, SHAcol) = SHA Or I = 1 Then
            For X = 1 To UBound(InArray, 2)
                OutArray(Y, X) = InArray(I, X)
            Next X
            Y = Y   1
        End If
    Next I
    
    WS.Range("A1").Resize(lRow, lCol) = OutArray
    
End Sub

This is the Data I used to test:

This is the output I get from SHA = 12

And this is the sub I was using to call it, just for reference. don't use it.

Sub CallWSxfer()
    
    Dim SHA As Long
    
    ' Or pull it from whatever drop down you're using...
    SHA = InputBox("Enter SHA Number:", "SHA to New Sheet", "01")

    Transfer_to_NewSheet Sheet4, SHA
    
End Sub

CodePudding user response：

you can use AutoFilter() method of Range object:

assuming:

data have headers in row 10 from column 1 rightwards and don't have blank rows/columns in between
the searched SHA will always be found in data column F

you could place this snippet right after your MsgBox "Sheet created : " & ws.Name, vbInformation code line

   With Sheets("user")
        With .Range("A10").CurrentRegion 

            .AutoFilter field:=6, Criteria1:=sName
            .SpecialCells(XlCellType.xlCellTypeVisible).Copy ws.Range("A1")
            
        End With
        .AutoFilterMode = False
   End With