エクセルVBAで下記のように複数列にセル内改行があった時に
1改行を1行として分割をしたい場合、
【A列】
a1作業日(項目名)
a2(改行あり)
2013/4/1
2013/4/3
a3(改行なし)
2013/4/1
a4(改行あり)
2013/4/1
2013/4/2
【B列】
b1終了日(項目名)
b2(改行あり)
2013/4/2
2013/4/10
b3(改行なし)
2013/4/2
b4(改行あり)
2013/4/15
2013/4/20
↓
A 列 B列
作業日 終了日
1行目 2013/4/1 2013/4/2
2行目 2013/4/3 2013/4/10
3行目 2013/4/1 2013/4/2
4行目 2013/4/11 2013/4/15
5行目 2013/4/16 2013/4/20
としたいとき、何か良い方法はありますでしょうか?
よろしくお願いいたします。
No.7ベストアンサー
- 回答日時:
' ' 注)セル内に無駄な改行がある場合はEmpty値と看做されます。
Sub Re8024419_3()
Const SMSG = "空白セルがあります。$このマクロは空白セルがある場合は機能しません。$" _
& " 空白セルに ""- 空 -"" を埋めて継続する場合は OK$" _
& " このまま終了する場合は キャンセル"
Dim mtxP, vTmp, v
Dim rngS As Range, rngP As Range, rngBlank As Range, r As Range
Dim tnRows As Long, tnCols As Long
Dim cnR As Long, cnLines As Long, cnLTmp As Long, cnC As Long
Dim i&, j&
Set rngS = Sheets("Sheet3").Range("A1").CurrentRegion ' シート名指定!
On Error Resume Next
Set rngBlank = rngS.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rngBlank Is Nothing Then
If MsgBox(Replace(SMSG, "$", vbLf), vbOKCancel + vbInformation + vbDefaultButton2) = vbOK Then
rngBlank.Value = "- 空 -"
Else
Exit Sub
End If
End If
Set rngP = Sheets.Add.Range("A1") ' = Sheet4.Range("A1") '
tnRows = rngS.Rows.Count
tnCols = rngS.Columns.Count
ReDim mtxP(1 To tnRows * 3, 1 To tnCols)
cnR = 1
cnC = 0
For Each r In rngS
cnC = cnC + 1
vTmp = r.Value
cnLines = 0
If InStr(vTmp, vbLf) > 0 Then
vTmp = Split(vTmp, vbLf)
For Each v In vTmp
mtxP(cnR + cnLines, cnC) = v
cnLines = cnLines + 1
Next
Else
cnLines = 1
mtxP(cnR, cnC) = vTmp
End If
If cnC = 1 Then
cnLTmp = cnLines
Else
If cnLines > cnLTmp Then cnLTmp = cnLines
End If
If cnC = tnCols Then
cnR = cnR + cnLTmp
cnC = 0
End If
Next
For i = 2 To cnR - 1
For j = 1 To tnCols
If IsEmpty(mtxP(i, j)) Then mtxP(i, j) = mtxP(i - 1, j)
Next j
Next i
rngP.Resize(cnR - 1, tnCols).Value = mtxP
Set rngS = Nothing: Set rngP = Nothing
End Sub
No.6
- 回答日時:
セル内の改行を直接処理し、数も2つ限定ではなく任意の数を想定しているので、ソコから先の位置合わせ、数合わせ、的なお仕事には、関知しません、、、
例えば、Max2個、下だけが欠けているとか、限定条件であれば、
最終フェーズのオマケ処理にあるような、空行削除みたいなやり方でのフォローは十分可能でヒョウ、、、
xLast = .UsedRange.Rows.Count
For nn = xLast To (xHeads + 1) Step -1
If (Application.WorksheetFunction.CountA(.Rows(nn)) = 0) Then
.Rows(nn).Delete
End If
Next
No.5
- 回答日時:
失礼、1ヶ所ミスりました。
#4は破棄してください。#元のシートの■!シート名を指定!■しないと動きません
Sub Re8024419j()
Dim vTmp
Dim mtxP
Dim v
Dim rngS As Range
Dim rngP As Range
Dim rCol As Range
Dim r As Range
Dim cnRows As Long
Dim cnLines As Long
Dim cnTmp
Dim cnCols As Long
Set rngS = Sheets("シート名").Range("A2").CurrentRegion.Resize(, 2) ' ■!シート名を指定!■
Set rngP = Sheets.Add.Range("A:B")
ReDim mtxP(1 To rngS.Rows.Count * 3, 1 To 2)
cnRows = 1
For Each r In rngS
cnCols = r.Column
vTmp = r.Value
cnLines = 0
If InStr(vTmp, vbLf) > 0 Then
vTmp = Split(vTmp, vbLf)
For Each v In vTmp
mtxP(cnRows + cnLines, cnCols) = v
cnLines = cnLines + 1
Next
Else
cnLines = 1
mtxP(cnRows, cnCols) = vTmp
End If
If cnCols = 1 Then
cnTmp = cnLines
Else
If cnLines > cnTmp Then cnTmp = cnLines
cnRows = cnRows + cnTmp
End If
Next
rngP.Resize(cnRows-1).Value = mtxP
Set rngS = Nothing: Set rngP = Nothing
End Sub
この回答への補足
何度も同じような質問をしてしまい申し訳ございません。
更に質問ですが、
開始日が2日(2行)あるのに対し、終了日が1日(1行)の場合、
対応者・終了日を開始日にあわせて2行それぞれに反映させる方法があれば教えてください。
※現状、1セル2改行までとなっています。
よろしくお願いいたします。
【A列】
a1作業日(項目名)
a2(改行あり)
2013/4/1
2013/4/3
a3(改行なし)
2013/4/1
a4(改行あり)
2013/4/1
2013/4/2
※開始日は2日
【B列】
b1対応者(項目名)
b2(改行あり)
Aさん
Bさん
b3(改行なし)
Cさん
b4
Dさん(改行なし)
【C列】
c1終了日(項目名)
c2(改行あり)
2013/4/2
2013/4/10
c3(改行なし)
2013/4/2
c4(改行なし)
2013/4/15
※終了日は1日のみ
↓
A 列 B列 C列
作業日対応者完了日
1行目 2013/4/1Aさん2013/4/2
2行目 2013/4/3Bさん2013/4/10
3行目 2013/4/1Cさん2013/4/2
4行目 2013/4/1Dさん2013/4/15※
5行目 2013/4/2Dさん2013/4/15※
※終了日は対応者が1人で1日ですが、2行に分割された際
2行ともに同一の人・終了日が反映される。
No.4
- 回答日時:
Sub Re8024419j()
Dim vTmp
Dim mtxP
Dim v
Dim rngS As Range
Dim rngP As Range
Dim rCol As Range
Dim r As Range
Dim cnRows As Long
Dim cnLines As Long
Dim cnTmp
Dim cnCols As Long
Set rngS = Sheets("シート名").Range("A2").CurrentRegion.Resize(, 2) ' ■!適宜指定!■ ' シート名
Set rngP = Sheets.Add.Range("A:B")
ReDim mtxP(1 To rngS.Rows.Count * 3, 1 To 2)
cnRows = 1
For Each r In rngS
cnCols = r.Column
vTmp = r.Value
cnLines = 0
If InStr(vTmp, vbLf) > 0 Then
vTmp = Split(vTmp, vbLf)
For Each v In vTmp
mtxP(cnRows + cnLines, cnCols) = v
cnLines = cnLines + 1
Next
Else
cnLines = 1
mtxP(cnRows, cnCols) = vTmp
End If
If cnCols = 1 Then
cnTmp = cnLines
Else
If cnTmp > cnLines Then cnTmp = cnLines
cnRows = cnRows + cnTmp
End If
Next
rngP.Resize(cnRows-1).Value = mtxP
Set rngS = Nothing: Set rngP = Nothing
End Sub
No.3
- 回答日時:
Option Explicit
Sub セルを改行で分割()
Const xName = "Sheet119" '出力シート名
Const xCol_From = 1 '処理対象列番号(From)
Const xCol_To = 2 '処理対象列番号(To)
Const xHeads = 1 'ヘッダ(見出し)行数
Dim xSheet As Worksheet
Dim xPart As Variant
Dim xLast As Long
Dim xRow As Long
Dim jj As Long
Dim kk As Long
Dim mm As Long
Dim nn As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Set xSheet = ActiveSheet
Worksheets(xName).Delete
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = xName
With Worksheets(xName)
Application.CutCopyMode = False
xSheet.Rows(1).Resize(xHeads).Copy
.Rows(1).PasteSpecial
'xLast = xSheet.Cells(Rows.Count, "A").End(xlUp).Row
xLast = xSheet.UsedRange.Rows.Count
For nn = (xHeads + 1) To xLast
Application.CutCopyMode = False
mm = .UsedRange.Rows.Count + 1
xSheet.Rows(nn).Copy
.Cells(mm, "A").PasteSpecial
xRow = mm
For kk = xCol_From To xCol_To
mm = xRow
xPart = Split(xSheet.Cells(nn, kk).Value, vbLf)
If (UBound(xPart) > 0) Then
For jj = 0 To UBound(xPart)
.Cells(mm, kk).Value = Application.WorksheetFunction.Clean(xPart(jj))
Debug.Print .Cells(mm, kk).Address & ":" & .Cells(mm, kk).Value & ":" & jj & "/" & UBound(xPart)
mm = mm + 1
Next
Else
' .Cells(mm, kk).Value = xSheet.Cells(nn, kk).Value
End If
Next
Next
xLast = .UsedRange.Rows.Count
For nn = xLast To (xHeads + 1) Step -1
If (Application.WorksheetFunction.CountA(.Rows(nn)) = 0) Then
.Rows(nn).Delete
End If
Next
xLast = .UsedRange.Rows.Count
.Rows((xHeads + 1) & ":" & xLast).AutoFit
End With
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
この回答への補足
1度に質問せずに申し訳ございません。
更に質問ですが、
開始日が2日(2行)あるのに対し、終了日が1日(1行)の場合、終了日を開始日にあわせて2行それぞれに反映させる方法があれば教えてください。
よろしくお願いいたします。
【A列】
a1作業日(項目名)
a2(改行あり)
2013/4/1
2013/4/3
a3(改行なし)
2013/4/1
a4(改行あり)
2013/4/1
2013/4/2
※開始日は2日
【B列】
b1終了日(項目名)
b2(改行あり)
2013/4/2
2013/4/10
b3(改行なし)
2013/4/2
b4(改行なし)
2013/4/15
※終了日は1日のみ
↓
A 列 B列
作業日 終了日
1行目 2013/4/1 2013/4/2
2行目 2013/4/3 2013/4/10
3行目 2013/4/1 2013/4/2
4行目 2013/4/11 2013/4/15※
5行目 2013/4/16 2013/4/15※
※終了日が1日ですが、2行に分割された際
2行ともに同一の終了日が反映される。
No.2
- 回答日時:
割とベタな手で。
Sub macro1()
Dim c As Long
Dim r As Long
Dim d()
Dim x
For c = 1 To Range("IV1").End(xlToLeft).Column
ReDim d(0)
d(0) = Cells(1, c)
For r = 2 To Cells(65536, c).End(xlUp).Row
For Each x In Split(Cells(r, c), vbLf)
’要素を1つずつ配列に拾っていく
ReDim Preserve d(UBound(d) + 1)
d(UBound(d)) = x
Next
Next r
Cells(1, c).Resize(UBound(d) + 1, 1) = Application.Transpose(d)
Next c
End Sub
No.1
- 回答日時:
こんにちは。
For Each ... Next ループで統一してみました。
一応、各列の行数に不整合があったりしても各列でコンプリートします。
動作確認できたら
Application.ScreenUpdating = False
など、自信のある範囲で追記してみるのもアリと思います。
Sub Re8024419c()
Dim vTmp ' ソースのセル範囲、各セルの値、または値配列
Dim v ' 配列変数の各値
Dim rngS As Range ' ソースのセル範囲
Dim rngP As Range ' 出力先のセル範囲(左上のセルのみ参照)
Dim rCol As Range ' ソースのセル範囲、各列
Dim r As Range ' ソースのセル範囲、各セル
Dim cnRows As Long ' 出力先のセル、相対的行位置
Dim cnCols As Long ' 出力先のセル、相対的列位置
Set rngS = Range("A1:B6") ' ■!適宜指定!■ ' ソース
Set rngP = Range("D1") ' ■!適宜指定!■ ' 出力先
cnCols = 0
' ' Application.ScreenUpdating = False
For Each rCol In rngS.Columns
cnCols = cnCols + 1 ' 出力先の列をカウント
cnRows = 0
For Each r In rCol.Cells
vTmp = r.Value
If InStr(vTmp, vbLf) > 0 Then ' セル内改行が見つかれば
vTmp = Split(vTmp, vbLf) ' セル内改行を区切り文字にした配列
For Each v In vTmp
cnRows = cnRows + 1 ' 出力先の行をカウント
rngP(cnRows, cnCols) = v ' 出力
Next
Else
cnRows = cnRows + 1 ' 出力先の行をカウント
rngP(cnRows, cnCols) = vTmp ' 出力
End If
Next r
Next
Set rngS = Nothing: Set rngP = Nothing
End Sub
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 改行ごとに行を追加し、数量を分割 4 2023/07/11 16:39
- Visual Basic(VBA) 指定列最終行までのスペースを改行するVBAについて 2 2022/06/01 19:50
- Visual Basic(VBA) Excel VBA 最終行を取得しVlookup関数をコピーする方法をコーディングで教えてください。 3 2023/05/11 13:14
- Visual Basic(VBA) vbaエクセルマクロ RemoveDuplicatesについて RemoveDuplicatesを使 3 2023/02/28 01:13
- Excel(エクセル) Countifよりも早く重複数をカウントする方法ありますか? 18 2022/07/04 13:39
- Visual Basic(VBA) vbaエクセルマクロ RemoveDuplicatesについて RemoveDuplicatesを使 1 2023/02/27 22:21
- Visual Basic(VBA) エクセルVBAで『A列』に新規で数値を入力し『B列』から右方向の空白セルにその値を貼り付ける方法 4 2022/11/05 08:37
- Excel(エクセル) エクセル VBA セルの結合 2 2022/09/07 11:48
- Visual Basic(VBA) 列と行の名前(重複あり)が交差するセルに、データを入力したい 2 2022/06/25 22:42
- Excel(エクセル) Excelで、行に複数の数字が入力されているセルが複数の列存在し、行を跨いでセル内の数値を並び替える 5 2022/06/17 18:03
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
SUMIF関数で、「ブランク以外を...
-
文字列から英数字のみを抽出す...
-
エクセル1行おきのセルを隣の...
-
自分の左隣のセル
-
excelで、空白を除いてデータを...
-
EXCELのcountif関数での大文字...
-
エクセルで、指定の値よりも大...
-
エクセルでエンターを押すと任...
-
EXCELでマイナス値の入ったセル...
-
【Excel】4つとばしで合計する方法
-
エクセルで特定のセル内にだけ...
-
Excelで離れた位置のAVERAGEを...
-
週の労働時間を計算するエクセル
-
Excelで大量のセルに一気に関数...
-
エラー「#REF」の箇所を置き換...
-
セルを結合した時のエクセル集...
-
同一セル内の重複文字を削除し...
-
条件付き書式の色付きセルのカ...
-
エクセル 平日と土日祝の時間...
-
エクセル2010 欠席者の名前を...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
SUMIF関数で、「ブランク以外を...
-
文字列から英数字のみを抽出す...
-
エクセル1行おきのセルを隣の...
-
自分の左隣のセル
-
エクセルで、指定の値よりも大...
-
excelで、空白を除いてデータを...
-
セルを結合した時のエクセル集...
-
エクセルで、A2のセルにA3...
-
エクセルで年月日から月日のみへ
-
エクセルに入力後、別シートの...
-
【Excel】4つとばしで合計する方法
-
Excelで大量のセルに一気に関数...
-
エクセルで特定のセル内にだけ...
-
EXCELのcountif関数での大文字...
-
EXCELでマイナス値の入ったセル...
-
条件付き書式の色付きセルのカ...
-
エラー「#REF」の箇所を置き換...
-
Excelで離れた位置のAVERAGEを...
-
同一セル内の重複文字を削除し...
-
週の労働時間を計算するエクセル
おすすめ情報