搜索相關標題并排列在旁邊的表格中

我是論壇的新手，也是學習 VBA 的新手。我已經在 Excel 上花費了 5,000 多個小時，但在 VBA 上花費的時間不超過 40 小時。

我正在嘗試使用 VBA 解決問題，但未能解決該任務。

我想在新表 F4：Q11 中排列單元格區域 B4：D11 中的關聯標題（A、B、C）。

表輸入和輸出

我的方法如下：

1. 將月份轉換為數字（例如，三月是數字 3）
2. 然后我從 E 列的同一行（第 4 行）開始，并將欄位數向右移動（例如，從 E4 開始 向右 3 個欄位，然后我在 H4）。
3. 標題“A”應粘貼在H4中。不幸的是，我不知道如何到達開頭的“A”。

不幸的是，我也不知道如何從中創建一個回圈，該回圈遍歷每行中的所有 3 個欄位（例如 B4、B5、B6），然后在下面的行中執行相同的操作。

有人可以幫我實施嗎:)

先感謝您！

uj5u.com熱心網友回復：

這是一種方法。請注意月份名稱必須匹配（螢屏截圖中的某些名稱不匹配 - 例如 March vs. Marz）

Sub Tester()
    Dim ws As Worksheet, rngMonths As Range
    Dim rw As Range, c As Range, i As Long, v, m
    
    Set ws = ActiveSheet
    Set rngMonths = ws.Range("F3:Q3")
    
    Set rw = ws.Range("A4:D4")                       'first row of name months
    Do While Application.CountA(rw) > 0              'while row is not empty...
        For i = 2 To rw.Cells.Count                  'loop from second cell of row
            Set c = rw.Cells(i)
            v = c.Value
            If Len(v) > 0 Then                         'if cell is not empty
                m = Application.Match(v, rngMonths, 0) 'see if it matches a month
                If Not IsError(m) Then                 'got a match?
                    'populate the header above `c`
                    ws.Cells(rw.Row, rngMonths.Cells(m).Column).Value = _
                                ws.Cells(3, c.Column).Value
                End If
            End If
        Next i
        Set rw = rw.Offset(1, 0) 'move down one row
    Loop
End Sub

uj5u.com熱心網友回復：

輸出場景 F4:Q11

看看下面的代碼：

Option Explicit

Sub ArrangeData()
    'define variables:
    Dim wsh As Worksheet, dictMonts As Dictionary
    Dim i As Integer, j As Integer, k As Integer
    Dim h As Integer, hc As Integer, ic As Integer
    Dim sMonth As String
    
    On Error GoTo Err_ArrangeData
    
    'worksheet where data are stored
    Set wsh = ThisWorkbook.Worksheets(1)
    'create dictionary object and load months with corresponding number of month
    Set dictMonts = GetMonths()
    
    'start inserting data in column F
    ic = 6
    'header is in row...
    h = 3
    'column count
    hc = 3
    'loop through the collection of rows
    i = 4
    Do While wsh.Range("A" & i) <> ""
        'start from column 1
        j = 1
        'loop through the collection of columns (on the right of Heading)
        Do While j <= hc
            'if empty cell - skip it and go to the next column:)
            If wsh.Range("A" & i).Offset(ColumnOffset:=j) = "" Then GoTo SkipNext
            'get the name of month
            sMonth = wsh.Range("A" & i).Offset(ColumnOffset:=j)
            'insert a columns header into corresponding cell
            wsh.Cells(i, ic).Offset(ColumnOffset:=dictMonts(sMonth) - 1) = wsh.Range("A" & hc).Offset(ColumnOffset:=j)
            'dictMonts(sMonth) - returns the number of month: 1 to 12
            'so we need to subtract 1 to start from column F[6]
SkipNext:
            j = j   1
        Loop
        i = i   1
    Loop
    
    
Exit_ArrangeData:
    On Error Resume Next
    Set wsh = Nothing
    Exit Sub
    
Err_ArrangeData:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_ArrangeData
End Sub

'function which creates and returns dictionary object
'stores the names of months and related numbers
Private Function GetMonths() As Dictionary
    Dim oDict As Dictionary
    Set oDict = New Dictionary
    
    oDict.Add "Januar", 1
    oDict.Add "Februar", 2
    oDict.Add "Marz", 3
    oDict.Add "April", 4
    oDict.Add "May", 5
    oDict.Add "Juni", 6
    oDict.Add "July", 7
    oDict.Add "August", 8
    oDict.Add "September", 9
    oDict.Add "October", 10
    oDict.Add "November", 11
    oDict.Add "December", 12
        
    Set GetMonths = oDict
    
End Function

您可以從我的服務器下載7z 存檔。

注意：您可能會看到有關不安全連接的警告，但我可以確認一切正常。我正在使用 Let's Encrypt 的 SSL 證書，但該服務暫時不可用。

標籤：擅长 vba

上一篇：如何在ExcelVBA中合并和求和到新列

下一篇：無法跳過VBA組合創建器中的空單元格