2

現在、VBA マクロを使用したい Excel スプレッドシートがあるという問題に取り組んでいます。次の 3 つの行はそれぞれ連続しています。

Name of Data                                                            
abc A1  B2  B4  C4  E2  F43 d4  V8  f9  k11 j20 …           x

cde A2  B3  B12 C6  E9  F34 d6  V4  f13 k111    j209    …           x

efg A3  B5  B7  C8  E11 F68 d19 V12 f91 k114    j2014   …           x
…       






Desired                                                         
abc A1  B2  B4  C4  E2  F43 d4  V8                          
abc f9  k11 j20 …                                           
cde A2  B3  B12 C6  E9  F34 d6  V4                          
cde f13 k111    j209    …                                           
efg A3  B5  B7  C8  E11 F68 d19 V12                         
efg f91 k114    j2014   …

各行のデータ名があり、一部の行は数百の列にまたがる数百のエントリになる場合があります。だから私がしたいのは、行の長さを8列幅で止めることです。マクロが各行をチェックして、長さが8より大きいかどうかを確認し、同じデータ名の行を挿入して次の8列を貼り付け、合計列からそれを差し引いて次の行を貼り付けることができることを願っています。最初の長い行の終わりに達し、すべての行をチェックし続けます。本質的には、幅 8 列をカウントアップし、それを下に挿入された行にカット アンド ペーストして、他のすべてのデータを保持することで、かなりの時間を節約できます。私はこれが初めてなので、マクロまたは VBA のヘルプをいただければ幸いです。

ありがとう、ジョン

4

2 に答える 2

1

以下のマクロは、あなたが求めるとおりに実行します。修正するためにあなたに任せるいくつかの仮定があります。

  • データはシート 1 にあります
  • 名前列は常にAで、すべてのデータ列はBから始まります
  • すべてはセルA1から始まります

このマクロはすべての行で実行され、データ要素が 9 つを超える行については、新しい行が作成され、前の行Nameと残りのデータ行が入力されます。行あたりのデータ要素が 8 以下になるまで、これを続けます。

あなたが言う多くの行があるので、 for ループの前のように画面の更新をオフApplication.ScreenUpdating = Falseにし、 for ループの後にオンに戻すことをお勧めします。

Public Sub SplitRows()

Dim rowRange As Variant
Dim colCount As Integer
Dim lastColumn As Long
Dim rowCount As Integer
rowCount = Cells(Rows.Count, "A").End(xlUp).Row

Dim i As Integer
i = 1
Do While (i < rowCount)
    lastColumn = Sheet1.Cells(i, Columns.Count).End(xlToLeft).Column
    colCount = Sheet1.UsedRange.Columns.Count
    rowRange = Range(Cells(i, 2), Cells(i, colCount))
    'if the row has more than 9 values (name column + 8 data columns)
    If Not lastColumn <= 8 Then
        Dim x As Integer
        'from column 2 (B, aka first data column) to last column
        For x = 2 To colCount - 1
           'if data is not empty AND x mod 8 is 1 (meaning 8 goes into x enough times to have a remainder of 1)
            If Not IsEmpty(rowRange(1, x - 1)) And (x Mod 8) = 1 Then
                Cells(i, 1).Offset(1).EntireRow.Insert  'insert new row below current row
                rowCount = rowCount + 1                 'update row count because we added a row
                Sheet1.Cells(i + 1, 1).Value = Sheet1.Cells(i, 1).Value     'set first column name
                Dim colsLeft As Integer
                For colsLeft = x To colCount - 1
                    'take data value from col 9 to end and populate newly created row
                    Sheet1.Cells(i + 1, colsLeft - 7).Value = rowRange(1, colsLeft)
                    Sheet1.Cells(i, colsLeft + 1).Value = ""    'set data value from col 9 on and set to empty
                Next
            Exit For    'exit loop, weve done all we need to and must now check the newly populated row
            End If
        Next
    End If
    i = i + 1
Loop
End Sub

結果の前後は次のとおりです。

前

マクロ前: 後 マクロの後:

于 2013-01-10T18:05:56.430 に答える
0

ああ、私はこの線に沿っていくらか試みました、しかし私は仕事に行かなければなりません。多分それは出発点として役立つでしょう。

Public Sub Test()
Dim mastercell As Range
Set mastercell = ActiveWorkbook.Worksheets(1).Cells(1, 1)
Dim masterValue As String
masterValue = mastercell.Value

If GetCount(masterValue) > 8 Then
    Dim tempvalue As String
    tempvalue = masterValue
    Dim Rowcount As Integer
    Dim ColCount As Integer
    Rowcount = mastercell.Row
    ColCount = mastercell.Column + 1
    Do While GetCount(tempvalue) > 8
        Dim WriteValue As String
        WriteValue = GetFirstEight(tempvalue)
        ActiveWorkbook.Worksheets(1).Cells(Rowcount, ColCount).Value = WriteValue
        ColCount = ColCount + 1
        tempvalue = Replace(tempvalue, WriteValue, 0, 1)

    Loop
End If

End Sub

Private Function GetCount(str As String) As Integer
Dim Splitter As String
Splitter = " "
Dim SplitArray As Variant
 SplitArray = Split(str)
GetCount = UBound(SplitArray)
End Function

Private Function GetFirstEight(str As String) As String
Dim i As Integer
Dim NewString As String
Dim SplitArray() As String
SplitArray = Split(str)
For i = 0 To 7
    NewString = NewString & SplitArray(i) & " "
Next
GetFirstEight = NewString
End Function
于 2013-01-10T08:25:40.773 に答える