Excel文字セルを詰める

質問

Excelで決まった枠がありセルに文字がバラバラに打ち込まれており空白セルを無視して文字セルを上から詰めたいのですがどなたかVBAが解る方よろしくお願いします。因みにwindows2007 offise2003です。

回答No.1

watabe007 · ベストアンサー

参考に
Sub Test()
　　Dim retu As Range, c As Range, i As Long, j As Long
　　For Each retu In Range("B4:E13").Columns
　　　　i = 3: j = 15
　　　　For Each c In retu.Cells
　　　　　　If c.Value <> "" Then
　　　　　　　　i = i + 1
　　　　　　　　Cells(i, c.Column).Offset(, 6).Value = c.Value
　　　　　　End If
　　　　　　If c.Offset(12).Value <> "" Then
　　　　　　　　j = j + 1
　　　　　　　　Cells(j, c.Column).Offset(, 6).Value = c.Offset(12).Value
　　　　　　End If
　　　　Next
　　Next
End Sub

お礼

ありがとうございます。大変勉強になり助かりました。

回答No.4

imogasi

各セルを繰り返し法で、空白か判別する方法（ロジック）を思いつきやすいが、
Excelでは、空白セルを選択する操作がある。したがってVBAでもそれが使える。
こういうのを使うと、VBAのコードは少なくて済む場合が多い。
Sub test02()
rngs = Array("a1:A10", "C1:C10", "F1:F10")　’10はバラバラでも良い
For Each Rng In rngs
Worksheets("Sheet1").Range(Rng).Copy Worksheets("Sheet2").Range(Rng)
Worksheets("Sheet2").Select
Range(Rng).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete (xlShiftUp)
Next
End Sub
ーー
例データ　Sheet1　A,C,F列１－１０行
aa rr
dd
ss ttt
fff ggg

dd hh hhhh
ff hhhj
jj eee
ff
dd
ーー
実行結果
Sheet2のA,C,F列
aa dd rr
ss fff ttt
dd hh ggg
ff jj hhhh
dd ff hhhj
eee

お礼

ありがとうございます。勉強になりました。

回答No.3

kkkkkm

No2の補足です。

Dim mRow As Long, mColumn As Long
は不要でした。

また、別の個所に結果を出したい場合
mRange = mData2
を(添付図例のように右に6列移動したところへ出す場合)
mRange.Offset(0, 6) = mData2
としてください。

お礼

ありがとうございます。

回答No.2

kkkkkm

範囲が例の範囲だと考えて2箇所分です。
Exampleを実行して下さい。

Sub Example()
Call mSet(Range("B4:E14"))
Call mSet(Range("B16:E26"))
End Sub

Function mSet(mRange As Range)
Dim mData As Variant, mData2 As Variant
Dim mRow As Long, mColumn As Long
Dim c As Long, r As Long, r2 As Long

mData = mRange
ReDim mData2(1 To UBound(mData), 1 To UBound(mData, 2))

For c = 1 To UBound(mData, 2)
r2 = 1
For r = 1 To UBound(mData)
If mData(r, c) <> "" Then
mData2(r2, c) = mData(r, c)
r2 = r2 + 1
End If
Next
Next
mRange = mData2
End Function

お礼

ありがとうございます。勉強になります。