ここから本文です

マクロ超初心者です。困っています。 マクロを使って添付画像のような処理をし...

アバター

ID非公開さん

2015/5/318:30:09

マクロ超初心者です。困っています。

マクロを使って添付画像のような処理をしたいのですが、
プログラムの書き方が全くわかりません…。

添付だけだと伝わらないかもしれませんが、
1つの号機の情報を1行にまとめたいのです。
(号機が空白の情報は、同じ管理番号内の号機で共通している)

どなたかご教示いただけると大変助かります。
よろしくお願いします。

Rng.Offset,sh1.Range,iPosE,C&quot,1 To UBound,LastRow,添付

閲覧数:
137
回答数:
3
お礼:
500枚

違反報告

ベストアンサーに選ばれた回答

kik********さん

2015/5/408:56:26

雰囲気以下でどうなりますか

結果は新シートに出力します


Public Sub Samp1()
   Dim vA As Variant
   Dim iPosS As Long, iPosE As Long
   Dim i As Long, j As Long, k As Long

   vA = Range("B2", Range("B2").End(xlDown)).Resize(, 7).Value
   iPosS = 2
   iPosE = iPosS
   For i = iPosE + 1 To UBound(vA)
      If (vA(iPosE, 1) <> vA(i, 1)) Then
         iPosS = iPosE + 1
         iPosE = iPosS
         For j = 1 To UBound(vA, 2)
            vA(iPosE, j) = vA(i, j)
         Next
      Else
         If (vA(iPosE, 2) = vA(i, 2)) Then
            For j = 3 To UBound(vA, 2)
               If (vA(i, j) <> "") Then
                  vA(iPosE, j) = vA(i, j)
               End If
            Next
         ElseIf (vA(i, 2) <> "") Then
            iPosE = iPosE + 1
            For j = 1 To UBound(vA, 2)
               vA(iPosE, j) = vA(i, j)
            Next
         Else
            For j = 3 To UBound(vA, 2)
               If (vA(i, j) <> "") Then
                  For k = iPosS To iPosE
                     vA(k, j) = vA(i, j)
                  Next
               End If
            Next
         End If
      End If
   Next

   Worksheets.Add After:=ActiveSheet
   With Range("B2").Resize(iPosE, UBound(vA, 2))
      .Value = vA
      .HorizontalAlignment = xlCenter
      .Borders.LineStyle = xlContinuous
      .Offset(1).Resize(iPosE - 1).Interior.ColorIndex = 34
   End With
End Sub

  • アバター

    質問者

    ID非公開さん

    2015/5/420:50:11

    ありがとうございます。
    かなりいい感じです!
    あと、今は列が項目1~5までですが、
    これが今後増えた場合にも対応できるようコードを改造できますでしょうか?
    お願いばかりですみません。。

  • その他の返信(3件)を表示

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

アバター

質問した人からのコメント

2015/5/5 17:02:13

補足も含め、これで問題なさそうですのでベストアンサーとさせていただきます。
ありがとうございました!

ベストアンサー以外の回答

1〜2件/2件中

並び替え:回答日時の
新しい順
|古い順

hel********さん

2015/5/407:24:08

添付図のセル位置を参考にした一例です。データはSheet1にあるとして、結果はSheet2に表示されます。

Sub Test()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim i As Long, LastRow As Long
Dim Hani As Range, rng As Range
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
LastRow = sh1.Range("B" & Rows.Count).End(xlUp).Row
With sh2
sh1.Range("B2:H2").Copy .Range("B2")
sh1.Range("C3:C" & LastRow).Copy .Range("C3")
.Range("C2:C" & LastRow).RemoveDuplicates Columns:=1, Header:=xlYes
Set Hani = .Range("C3:C" & .Range("C" & Rows.Count).End(xlUp).Row)
For Each rng In Hani
For i = 3 To LastRow
If rng.Value = sh1.Range("C" & i).Value Then
rng.Offset(, 1) = rng.Offset(, 1) & sh1.Range("D" & i)
rng.Offset(, 2) = rng.Offset(, 2) & sh1.Range("E" & i)
rng.Offset(, 3) = rng.Offset(, 3) & sh1.Range("F" & i)
rng.Offset(, 4) = rng.Offset(, 4) & sh1.Range("G" & i)
rng.Offset(, 5) = rng.Offset(, 5) & sh1.Range("H" & i)
ElseIf sh1.Range("C" & i) = "" Then
rng.Offset(, 1) = rng.Offset(, 1) & sh1.Range("D" & i)
rng.Offset(, 2) = rng.Offset(, 2) & sh1.Range("E" & i)
rng.Offset(, 3) = rng.Offset(, 3) & sh1.Range("F" & i)
rng.Offset(, 4) = rng.Offset(, 4) & sh1.Range("G" & i)
rng.Offset(, 5) = rng.Offset(, 5) & sh1.Range("H" & i)
End If
Next i
Next rng
End With
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

por********さん

2015/5/400:04:05

こんにちは。
1) 最初の表から、データを縦一行にする処理を実行
2) ピボットテーブルで、ターゲットの表を作成する。

という手順で考えてください。
コードですが、最初のは、
gyo = 2
for i=3 to 25
for j=4 to 8
if cells(i,j).value = "" then
else
range("AA" & gyo).value = cells(i , "B").value
range("AB" & gyo).value = cells(i , "C").value
range("AC" & gyo).value = cells(2 , j).value '項目名の転記
range("Ad" & gyo).value = cells(i , j).value '表の文字列を転記
gyo = gyo + 1
end if
next
next
これで、AAからADにデータが集まるので、ピボットで項目を列フィールドにドロップ、管理番号は行フィールドにドロップ
ごうきは、行にドロップ
AD列をデータフィールドにドロップです。

集計したいものが、単純な数値でしたらいいのですが、「本当に文字列だけ」というのだと、
データに一度集まってから、そのデータに対して、for nextで、match関数で行と列を計算して転記することになります

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる