Excel 一個單元格到多個公式（我意識到這可能不可能）

Question

首先，我想說我知道這要么極其困難，要么不可能。

我有數據（來自維基百科，在航空公司和目的地列表中的任何機場上），一列是航空公司名稱，另一列是用逗號分隔的目的地列表，偶爾還有一些額外資訊。

我需要的是將每個目的地放在單獨的行中，旁邊是航空公司名稱，並在第三列中提供額外資訊（包機、季節性、「開始...」、參考）。

我將使用多個維基百科表重複執行此操作。我正在 Kumu.io 上創建路線圖。沒關係，任何解決方案都不能完成所有工作，我只需要一些接近的東西，因為我無法手動完成這一切。如果您需要更多信息，請告訴我。感謝您的幫助，這確實是一個很棒的資源。

數據是這樣的格式

我需要它看起來像

Answer 1

您的問題不清楚您是否確實有超連結（有些是彩色的，有些是帶下劃線的，有些不是）

我不知道這是否可以透過工作表函數來完成，但是這個 VBa 可以做到。

Option Explicit

Sub CrazyAirlines()

'************** There are things you may need to edit here

Dim currentRow As Integer
currentRow = 1 'I assume we start on row 1, if row 1 is actually headings, change this to the first row of data

Dim destinationRow As Integer
destinationRow = 1 ' assuming there is no heading again, if there is, change to a 2

Dim airlineCol As String
airlineCol = "A"

Dim destinationCol As String
destinationCol = "B"

Dim extraCol As String
extraCol = "C"

Dim origSheet As String
origSheet = "Sheet1" ' the name of of the sheet where the values currently live

Dim destSheet As String
destSheet = "Sheet2" ' this is the sheet name where the results will be

' *********** Hopefully you don't need to edit anything under this line!!

Worksheets(destSheet).Cells.Clear

Do While (Worksheets(origSheet).Range(airlineCol & currentRow).Value <> "")

    Dim airline As String
    airline = Worksheets(origSheet).Range(airlineCol & currentRow).Value

    Dim destinations As String
    destinations = Worksheets(origSheet).Range(destinationCol & currentRow).Value

    Dim extraInfo As String

    Dim title As String

    Dim spInfo() As String
    spInfo = Split(destinations, ":")

    If (UBound(spInfo) > 0) Then
        title = spInfo(0)
    End If

    destinations = Replace(destinations, title & ":", "")

    Dim spDest() As String
    spDest = Split(destinations, ",")

    Dim i As Integer

    For i = 0 To UBound(spDest)

        Worksheets(destSheet).Range(airlineCol & destinationRow).Value = RemoveSquare(Trim(airline))

        Dim des As String
        des = RemoveSquare(spDest(i))

        Dim containsExtra() As String
        containsExtra = Split(spDest(i), "(")

        If UBound(containsExtra) > 0 Then
            title = Replace(containsExtra(1), ")", "")
            des = containsExtra(0)
        End If

        Worksheets(destSheet).Range(destinationCol & destinationRow).Value = Trim(des)

        If (title <> "") Then
            Worksheets(destSheet).Range(extraCol & destinationRow).Value = title
            title = "" 'kill it, kaboom, bang, boom (not good words considering this is about airlines, but hilarious
        End If

        destinationRow = destinationRow + 1

    Next i

    currentRow = currentRow + 1
Loop

End Sub

Function RemoveSquare(s As String)

Dim sp() As String
sp = Split(s, "]")

    If UBound(sp) > 0 Then
        RemoveSquare = sp(1)
    Else
        RemoveSquare = s
    End If

End Function

Sheet1 看起來像

在我運行上面的 VBa 後，我的 Sheet2 看起來像