1

15,096 列のテキスト (セルごとに 1 語) を、元の列のすべてのセルを含む 1 つの大きな列に変換したいと考えています。元の列のサイズはさまざまです (つまり、ある列には 4 つのセル/行があり、別の列には 100 のセル/行がある場合があります)。

私は VBA の経験はありませんが、これを手動で行うマクロを記録したことがあります。私が設定してコーヒーを飲みに行き、仕事が終わったのを見に戻ってくることができる何かを手伝ってください. (注: 一部の列には 1 つの単語/行があります...これにより、マクロがこれらのいずれかに遭遇するたびにエラーがスローされます)。

ありがとうございました！誰かが助けてくれることを願っています。-マイク

4

4 に答える 4

2

すべてのセルを 1 列に揃えたい場合は、次のコードを使用できます。

Sub ToArrayAndBack()
Dim arr As Variant, lLoop1 As Long, lLoop2 As Long
Dim arr2 As Variant, lIndex As Long

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With


ReDim arr2(ActiveSheet.UsedRange.Cells.Count - ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).Count)

arr = ActiveSheet.UsedRange.Value


For lLoop1 = LBound(arr, 1) To UBound(arr, 1)
    For lLoop2 = LBound(arr, 2) To UBound(arr, 2)
        If Len(Trim(arr(lLoop1, lLoop2))) > 0 Then
            arr2(lIndex) = arr(lLoop1, lLoop2)
            lIndex = lIndex + 1
        End If
    Next
Next

Sheets.Add
Range("A1").Resize(, lIndex + 1).Value = arr2

Range("A1").Resize(, lIndex + 1).Copy
Range("A2").Resize(lIndex + 1).PasteSpecial Transpose:=True
Rows(1).Delete

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With


End Sub

各行を連結したい場合は、代わりにこれを使用してください。セルを新しいシートに統合します。

Sub Consolidate()
Dim shtDest As Worksheet, shtOrg As Worksheet
Dim lLastRow As Long, lLastCol As Long, lLoop As Long
Dim sFormula  As String

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With


Set shtOrg = ActiveSheet
lLastCol = shtOrg.UsedRange.Columns.Count
lLastRow = shtOrg.Cells(Rows.Count, 1).End(xlUp).Row

Set shtDest = Sheets.Add

For lLoop = 1 To lLastCol
    sFormula = sFormula & "'" & shtOrg.Name & "'!RC" & lLoop & ","
Next lLoop

sFormula = Left(sFormula, Len(sFormula) - 1)

shtDest.Range("A1:A" & lLastRow).FormulaR1C1 = "=concatenate(" & sFormula & ")"
shtDest.Range("A1:A" & lLastRow).Value = shtDest.Range("A1:A" & lLastRow).Value


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With


End Sub

または、セルをスペースで区切る場合

Sub Consolidate()
Dim shtDest As Worksheet, shtOrg As Worksheet
Dim lLastRow As Long, lLastCol As Long, lLoop As Long
Dim sFormula  As String

Const sSeparator As String = " "

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With


Set shtOrg = ActiveSheet
lLastCol = shtOrg.UsedRange.Columns.Count
lLastRow = shtOrg.Cells(Rows.Count, 1).End(xlUp).Row

Set shtDest = Sheets.Add

For lLoop = 1 To lLastCol
    sFormula = sFormula & "'" & shtOrg.Name & "'!RC" & lLoop & "&""" & sSeparator & ""","
Next lLoop

sFormula = Left(sFormula, Len(sFormula) - 1)

shtDest.Range("A1:A" & lLastRow).FormulaR1C1 = "=trim(concatenate(" & sFormula & "))"
shtDest.Range("A1:A" & lLastRow).Value = shtDest.Range("A1:A" & lLastRow).Value


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With


End Sub
于 2012-10-25T16:34:15.767 に答える
0 
Sub MultiColsToA() 
Dim rCell As Range 
Dim lRows As Long 
Dim lCols As Long 
Dim lCol As Long 
Dim ws As Worksheet 
Dim wsNew As Worksheet 

lCols = Columns.Count 
lRows = Rows.Count 
Set wsNew = Sheets.Add() 

For Each ws In Worksheets 
    With ws 
        For Each rCell In .Range("B1", .Cells(1, lCols).End(xlToLeft)) 
            .Range(rCell, .Cells(lRows, rCell.Column).End(xlUp)).Cut _ 
            wsNew.Cells(lRows, 1).End(xlUp)(2, 1) 
        Next rCell 
    End With 
Next ws 

End Sub
于 2012-10-25T16:27:38.753 に答える
0

記録したマクロに移動して、この行を先頭に挿入すると: 

Application.ScreenUpdating = False

次に、コードの最後で screenUpdating を true に戻します。これにより、マクロが変更のたびに変更を視覚的に表示するのを防ぐため、コードが劇的に高速化されます。これにより、グラフィックスへの多くの呼び出しが回避され、速度が低下します。

于 2012-10-25T16:31:46.217 に答える
0

ここに別の方法があります。これにより、行内のすべての文字列が結合され、結果の文字列が行の最初のセルに配置されます。つまり、そのセルにあったものはすべて上書きされます。 これは、ワークブックのコピーでこれを試す必要があることを意味します。意図したとおりに動作しない場合、データが失われるからです。

Sub MakeOneColumn()

    Dim rRow As Range
    Dim vaRow As Variant
    Dim i As Long
    Dim aJoin() As Variant

    'Loop through each row in the sheet
    For Each rRow In Sheet1.UsedRange.Rows

        'put the rows values in an array
        vaRow = rRow.Value

        'Convert the array from 2-d to 1-d because the Join function needs 1-d
        ReDim aJoin(LBound(vaRow, 2) To UBound(vaRow, 2))
        For i = LBound(vaRow, 2) To UBound(vaRow, 2)
            aJoin(i) = vaRow(1, i)
        Next i

        'Join the array into one string, replace double spaces, and write to the
        'first cell in the row (replacing what was there - so be careful)
        rRow.Cells(1).Value = Replace(Join(aJoin, Space(1)), Space(2), Space(1))
    Next rRow

End Sub
于 2012-10-25T18:25:39.013 に答える