我正在使用 Excel 中的提取檔案。它基本上是多列，每列都有幾行資料。
A | B | C | D | E | F |
1 | 2 | 3 | 1 | 2 | 3 |
4 | 5 | 5 | 4 | 5 | 5 |
我想將其展平為 3 列，如下所示：
A | B | C |
1 | 2 | 3 |
4 | 5 | 5 |
D | E | F |
1 | 2 | 3 |
4 | 5 | 5 |
我想使用 VBA 來做，但我對這種語言真的很陌生，這是我到目前為止所做的：
Sub test()
Dim Key, Dic As Object, cl As Range, Data As Range, i&, n&
Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = vbTextCompare
i = Cells(Rows.Count, "A").End(xlUp).Row
n = 1
Set Data = Range("B2:B" & i & "," & "D2:D" & i & "," & "F2:F" & i & "," & "H2:H" & i)
Dic.Add "|ID", "Date|Thing"
For Each cl In Data
If Cells(cl.Row, "A") <> "" Then
Dic.Add n & "|" & Cells(cl.Row, "A"), cl.Text & "|" & cl.Offset(, 1).Text
n = n 1
End If
Next cl
n = 1
For Each Key In Dic
Cells(n, "K") = Split(Key, "|")(1)
Cells(n, "L") = Split(Dic(Key), "|")(0)
Cells(n, "M") = Split(Dic(Key), "|")(1)
n = n 1
Next Key
End Sub
它給了我這個結果：
A | A | A |
B | B | B |
C | C | C |
1 | 1 | 1 |
2 | 2 | 2 |
3 | 3 | 3 |
4 | 4 | 4 |
5 | 5 | 5 |
6 | 6 | 6 |
D | D | D |
E | E | E |
F | F | F |
1 | 1 | 1 |
2 | 2 | 2 |
3 | 3 | 3 |
4 | 4 | 4 |
5 | 5 | 5 |
6 | 6 | 6 |
請問你能幫幫我嗎 ？
uj5u.com熱心網友回復：
除非我遺漏了一些東西，否則你把事情復雜化了。
如果你有這個：
...然后使用這個：
Range("D1:F3").Cut Range("A4")
...得到這個：
進入
您只需要定義所需的列數：Const AmountOfColumns As Long = 3
Option Explicit
Public Sub LimitColumns()
Const AmountOfColumns As Long = 3 ' define how many columns you want in the end
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Dim LastRow As Long ' amount of initial rows
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim LastCol As Long ' amount of initial columns
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Dim AmountOfSteps As Long ' amount of blocks we need to copy
AmountOfSteps = LastCol \ AmountOfColumns
Dim LastStep As Long ' if the last block is smaller
LastStep = LastCol Mod AmountOfColumns
' move all blocks
Dim s As Long
For s = AmountOfColumns 1 To AmountOfColumns * AmountOfSteps Step AmountOfColumns
ws.Cells(1, s).Resize(LastRow, AmountOfColumns).Cut ws.Cells(((s - 1) / AmountOfColumns) * LastRow 1, 1)
Next s
' move last block (if it has less columns than the others)
If LastStep > 0 Then
ws.Cells(1, AmountOfSteps * AmountOfColumns 1).Resize(LastRow, LastStep).Cut ws.Cells(AmountOfSteps * LastRow 1, 1)
End If
End Sub
這使用cut和paste，如果您只想移動值（不帶格式），您可以更改為：
' move all blocks
Dim s As Long
For s = AmountOfColumns 1 To AmountOfColumns * AmountOfSteps Step AmountOfColumns
ws.Cells(((s - 1) / AmountOfColumns) * LastRow 1, 1).Resize(LastRow, AmountOfColumns).Value2 = ws.Cells(1, s).Resize(LastRow, AmountOfColumns).Value2
Next s
' move last block (if it has less columns than the others)
If LastStep > 0 Then
ws.Cells(AmountOfSteps * LastRow 1, 1).Resize(LastRow, LastStep).Value2 = ws.Cells(1, AmountOfSteps * AmountOfColumns 1).Resize(LastRow, LastStep).Value2
End If
' clear old values
ws.Cells(1, AmountOfColumns 1).Resize(LastRow, LastCol - AmountOfColumns).ClearContents
這可能會更快。
uj5u.com熱心網友回復：
獲取堆疊列
- 如果您不是 OP，要對其進行測驗，您可以打開一個新作業簿并確保您有
Sheet1和Sheet2選項卡。將代碼復制到標準模塊，例如Module1.A1從單元格開始添加一些連續的資料（沒有空行或空列）Sheet1并運行第一個程序。在 中查看結果Sheet2。玩轉常數ColumnsCount，Gap看看它們如何改變結果。
Option Explicit
Sub GetStackedColumnsTEST()
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "A1"
Const ColumnsCount As Long = 3
Const Gap As Long = 0
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim Data As Variant: Data = GetStackedColumns(srg, ColumnsCount, Gap)
Dim rc As Long: rc = UBound(Data, 1)
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dFirstCellAddress).Resize(, ColumnsCount)
.Resize(rc) = Data
.Resize(dws.Rows.Count - .Row - rc 1).Offset(rc).ClearContents
End With
End Sub
Function GetStackedColumns( _
ByVal SourceRange As Range, _
ByVal ColumnsCount As Long, _
Optional ByVal Gap As Long = 0) _
As Variant
Const ProcName As String = "GetStackedColumns"
On Error GoTo ClearError
Dim rCount As Long: rCount = SourceRange.Rows.Count
Dim cCount As Long: cCount = SourceRange.Columns.Count
Dim sData As Variant: sData = SourceRange.Value
Dim StacksCount As Long: StacksCount = Int(cCount / ColumnsCount)
Dim ColumnCrumbs As Long: ColumnCrumbs = cCount Mod ColumnsCount
If ColumnCrumbs > 0 Then StacksCount = StacksCount 1
Dim drCount As Long
drCount = StacksCount * rCount (Gap * (StacksCount - 1))
Dim dData As Variant: ReDim dData(1 To drCount, 1 To ColumnsCount)
Dim st As Long, sr As Long, sc As Long, dr As Long, dc As Long
For st = 1 To StacksCount - 1
sc = (st - 1) * ColumnsCount
For sr = 1 To rCount
dr = dr 1
For dc = 1 To ColumnsCount
dData(dr, dc) = sData(sr, sc dc)
Next dc
Next sr
dr = dr Gap
Next st
If ColumnCrumbs = 0 Then ColumnCrumbs = ColumnsCount
sc = (st - 1) * ColumnsCount
For sr = 1 To rCount
dr = dr 1
For dc = 1 To ColumnCrumbs
dData(dr, dc) = sData(sr, sc dc)
Next dc
Next sr
GetStackedColumns = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
uj5u.com熱心網友回復：
因此，如果我理解這一點，您想更改如下內容：
像這樣：
您可以使用以下代碼實作此目的。請記住，我上次主動編程是幾年前的事了，所以這不是優化的。
Sub adjustList()
Dim columWhereToSplit As Integer
Dim lastColumn As Integer
Dim columnsFormatted As Integer
columWhereToSplit = 7
lastColumn = 12
columnsFormatted = 0
NumRows = Cells(Rows.Count, columWhereToSplit).End(xlUp).Row
For counter = columWhereToSplit To lastColumn
Cells(1, counter).Select
For counter_2 = 1 To NumRows
Cells(counter_2, counter).Select
Cells(NumRows counter_2, 1 columnsFormatted) = ActiveCell
ActiveCell = ""
Next
columnsFormatted = columnsFormatted 1
Next
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/yidong/440537.html
下一篇：VBA不斷將句點更改為逗號