试试这个（您需要重命名工作簿名称和工作表名称）：
Sub SO_19646599()
Dim oWB1 As Workbook, oWB2 As Workbook
Dim oWS1 As Worksheet, oWS2 As Worksheet
Dim oRngRef As Range, oRng1 As Range, oRng2 As Range
Dim sTmp As String, iOffset As Long, iErr As Long, sErr As String
' Source Workbook and Worksheet (assumed already open)
Set oWB1 = Workbooks("Wb1")
Set oWS1 = oWB1.Worksheets("Sheet1") ' Assuming Sheet1
' Target Workbook (assumed already open)
Set oWB2 = Workbooks("Wb2")
' Reference range to start
Set oRngRef = oWS1.Range("N6")
' Offset counter
iOffset = 0
' Loop until oRngRef is an empty cell
Do Until IsEmpty(oRngRef)
' Copy O6:AA6 to O1:AA1 in Wb1 (assuming Sheet1), with row offset
Set oRng1 = oWS1.Range("O6:AA6").Offset(iOffset, 0)
Set oRng2 = oWS1.Range("O1:AA1").Offset(iOffset, 0)
oRng1.Copy Destination:=oRng2
' Get reference to Worksheet in Wb2 by the value contained in N6 of Wb1 (assumed Sheet1), with row offset
sTmp = oRngRef.Value
Set oWS2 = oWB2.Worksheets(sTmp)
If oWS2 Is Nothing Then
iErr = iErr + 1
sErr = sErr & iErr & vbTab & "No such """ & sTmp & """ worksheet (" & oRngRef.Address & ") in " & oWB2.Name & vbCrLf
Else
' copies the columns B:E from Wb1 (Sheet1) to Wb2 (Sheet name as N6)
oWS1.Columns("B:E").Copy Destination:=oWS2.Columns("B:E")
End If
iOffset = iOffset + 1
' Update Reference range
Set oRngRef = oWS1.Range("N6").Offset(iOffset, 0)
Loop
If iErr > 0 Then
Debug.Print sErr
MsgBox iErr & " errors occurred, please review Immediate window." & vbCrLf & vbCrLf & sErr
End If
' Cleanup
Set oWS2 = Nothing
Set oWB2 = Nothing
Set oWS1 = Nothing
Set oWB1 = Nothing
End Sub