エクセルマクロ、教えてください。

質問

エクセルマクロ、教えてください。

とても困っています 泣
だれかご教授をおねがいいたします。

画像のような表があり、マクロボタンを押すと、画像下のように文字列にして別シートに出力したいのですが、
賢い形で作ることが出来ません。
if文がとても多くなってしまいます。
繰り返し処理などあるようなのですが、難しくてついていけません。
だれかきれいなロジックを教えていただけないでしょうか。
お願いいたします！

条件として、
表は、いくつかあり、画像は果物４種類ですが、野菜８種類の表などにも流用できるマクロをくみたいです。
A商店を左から順番に文字列に格納して、""になるまで繰り返す・・・
""がきたら、B商店へ・・・といった形でしょうか。
また、商店の数も不特定なので、こちらも""になるまで繰り返すという条件でお願いいたします！

エクセル関数で出来るじゃんとおもうでしょうが、例として簡単なものに書き換えただけなので、
回答はぜひマクロでお願いいたします！

回答No.4

Wendy02

#3のご指摘の「数量が０の時は表示しない方が良い」を反映しました。本来は、>0 の方がよいのですが、借りた場合のマイナス値は出力しまた。会社名だけでデータがない場合は、データがない時は、データがないと出力します。

'//
Private Sub CommandButton1_Click()
　Dim rng As Range, rng2 As Range
　Dim ar1, ar2, ar3(), i As Long, j As Long, k As Long
　Dim buf As String
　'範囲を取得
　Set rng = Range("A1").CurrentRegion
　ar1 = Application.Transpose(Application.Index(rng.Columns(1).Value, 0, 1))
　ReDim Preserve ar1(UBound(ar1) - 1)
　ar2 = Application.Index(rng.Rows(1).Value, 1, 0)
　ReDim Preserve ar2(UBound(ar2) - 1)

　With rng
　　Set rng2 = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
　　ReDim ar3(.Rows.Count - 1, 0)
　End With
　With rng2
　　For i = 1 To .Rows.Count
　　　For j = 1 To .Columns.Count
　　　　If .Cells(i, j).Value <> 0 Then '0でないときは
　　　　　buf = buf & "、" & ar2(j) & Val(.Cells(i, j).Value) & "個"
　　　　End If
　　　Next
　　　If buf <> "" Then 'データがないときは
　　　　ar3(k, 0) = ar1(i) & "は" & Mid(buf, 2)
　　　Else
　　　　ar3(k, 0) = ar1(i) & "のデータはありません。"
　　　End If
　　　buf = ""
　　　k = k + 1
　　Next
　　'出力先
　　Worksheets("Sheet2").Range("A1").Resize(rng2.Rows.Count).Value = ar3
　End With
　Set rng = Nothing: Set rng2 = Nothing
End Sub

回答No.3

jcctaira

※果物や野菜が複数でも対応可能にしました。
※数量が０の時は表示しない方が良いかも知れませんね。

Sub ボタン_Click()
　行 = 2
　While Cells(行, "A") <> ""
　　　列 = 2
　　　文字列 = Cells(行, "A") & "は"
　　　While Cells(1, 列) <> ""
　　　　　文字列 = 文字列 & Cells(1, 列) & Cells(行, 列) & "個、"
　　　　　列 = 列 + 1
　　　Wend
　　　文字列 = Left(文字列, Len(文字列) - 1)
　　　Sheets("Sheet2").Cells(行, "A") = 文字列
　　　行 = 行 + 1
　Wend
End Sub

回答No.2

kmetu

野菜８種類の表などにも流用できるというのを見逃してました。
以下のマクロでいかがですか。

Sub test()

Dim m_Str As String
Dim m_EndColumn As Long

m_EndColumn = Cells(1, Columns.Count).End(xlToLeft).Column

For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
m_Str = m_Str & Cells(i, 1).Value & "は、"
For j = 2 To m_EndColumn - 1
m_Str = m_Str & Cells(1, j).Value & Cells(i, j).Value & "個、"
Next
m_Str = m_Str & Cells(1, m_EndColumn).Value & Cells(i, m_EndColumn).Value & "個"
Sheets("Sheet2").Range("A" & i - 1).Value = m_Str
m_Str = ""
Next

End Sub

回答No.1

kmetu

Sub test()

For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet2").Range("A" & i - 1).Value = Range("A" & i).Value & "は" & _
"りんご" & Range("B" & i).Value & "個、" & _
"みかん" & Range("C" & i).Value & "個、" & _
"いちご" & Range("D" & i).Value & "個、" & _
"ぶどう" & Range("E" & i).Value & "個"

Next

End Sub

でいかがでしょう。