Macro to Copy range from multiple sheets and paste in new Workbook

I have a macro that takes info/data from multiple sheets in the Basin workbook and summarizes it into the Median Database workbook. I need to copy the values in range B5:EM5 in every sheet (each sheet name is site #) in the Basin workbook and paste that range into the median database workbook row with the corresponding site.

Here is what I have so far

Sub Median_Database() 
     
     'This Macro takes the median from each station tab in the current Basin workbook
     'And inserts it into the Median Database workbook
     
    Dim count As Integer 
    Dim wbk As Worksheet 
    Dim BasinWs As Worksheet 
     
     
     'Counts how many sheets are in the Basin workbook
    count = ThisWorkbook.Sheets.count 
     'this defines the Sheet "Count" in the Median Database
    Set wbk = Workbooks("Median Database").Sheets("Count") 
     'this defines the Sheet "Basin" in the Basin workbook
    Set BasinWs = ThisWorkbook.Sheets("Basin") 
     
     
     'Inserts blank rows in Median Database
    wbk.Activate 
    Range("B4:B" & count).Select 
    Selection.EntireRow.Insert 
     
    Dim i As Integer 
    For i = 1 To ThisWorkbook.Sheets.count 
        Set ws = ThisWorkbook.Worksheets(i) 
        ws.Activate 
         
         'this identifies sitenum with each station tab name in the Basin workbook
        Dim sitenum As String 
        sitenum = ws.Name 
         
        If Not ws.Name = "Pivot" _ 
        And Not ws.Name = "Basin" _ 
        And Not ws.Name = "Parameter Code Description" Then 
             
             
             'places the station tab name in the Median Database
            Dim x As Integer 
            For Each ws In Worksheets 
                For x = i To 4 Step -1 
                    If wbk.Cells(x, 2).Value = "" Then 
                        wbk.Cells(x, 2).Value = sitenum 
                    End If 
                    Range("B5:EM5").Copy 
                    wbk.Range("C" & x).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=False 
                Next x 
            Next ws 
             
             'Places the Basin number in the Median Database
            Dim r As Integer 
            BasinNum = BasinWs.Cells(2, 1).Value 
            For r = i To 4 Step -1 
                If wbk.Cells(r, 2).Value <> "" Then 
                    wbk.Cells(r, 1).Value = BasinNum 
                End If 
            Next r 
             
             
        End If 
         
    Next 
    Sheets("Pivot").Select 
     
    wbk.Activate 
    Range("A3").Select 
     
End Sub

I have figured out how to grab the sheet name and insert it in the median database. The problem is the copy/paste of the range in each sheet. The macro locks up every time.

Any help is greatly appreciated!!