ここから本文です

エクセルVBAの質問です。 初心者で昨日一日考えたのですが、全然うまくできなかっ...

utm********さん

2020/7/509:31:54

エクセルVBAの質問です。
初心者で昨日一日考えたのですが、全然うまくできなかったので質問させていただきます。

添付画像のとおりSheet1にデータがあります。

A列には番号があり、D列に金額があります。
完成イメージは添付画像のSheet2と書いてあるものです。
データは新しいSheet2に記載していきます。

同じ番号でも金額が異なることがあるため、金額のみを横に記載したいです。
なお、金額は順不同なため、昇順に転記していきたいです。


なお、データは、1000行40列などのデータ(データシートで行と列の数が異なる)です。
同様の処理をしなければならないシートがいくつかあるので、VBAでご回答いただけないでしょうか。

なお、全くお恥ずかしいのですが、以下のようにデータが空欄になるまで処理をするといったやり方でどうかと考えていました。
※無視してください。

(コード)
Sub KingakuRireki
Dim i, j, k As Integer
i = 2
j = 3
k = 5
Do Until Worksheets("Sheet1").Cells(j, 1) <> Worksheets("Sheet1").Cells(j - 1, 1)
If Worksheets("Sheet1").Cells(i + m, 1).Value = Worksheets("Sheet1").Cells(j, 1).Value Then
Worksheets("Sheet1").Cells(i + m, k).Value = Worksheets("Sheet1").Cells(j, 3).Value
End If
j = j + 1
k = k + 1
Loop

End Sub

Sheet1&amp;quot,k As Integer,If Worksheets,Cells,Value Then

閲覧数:
62
回答数:
3
お礼:
250枚

違反報告

回答

1〜3件/3件中

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

lgk********さん

2020/7/521:13:14

>同様の処理をしなければならないシートがいくつかある
しかし、Sheet1、Sheet2固定ですね。ワークブックがいくつもあるのでしょうか。
もしそうなら、個人用マクロブック(PERSONAL.XLSB) に入れておけばいいです。

Option Explicit
'
Sub Macro1()
    Dim I As Worksheet
    Dim RSta As Long
    Dim RInp As Long
    Dim ROut As Long
    Dim Index As Integer
    Dim Area As Range
'
    Set I = Sheets("Sheet1")
    Sheets("Sheet2").Select
    RSta = 1
    ROut = 1
    Application.ScreenUpdating = False
'
    For RInp = 2 To I.[A1].End(xlDown).Row
'
        If I.Cells(RInp, "A") <> I.Cells(RInp + 1, "A") Then
            [A1:C1].Offset(ROut) = I.[A1:C1].Offset(RSta).Value
            Set Area = I.Range("D" & RSta + 1, "D" & RInp)
            ROut = ROut + 1
'
            For Index = 1 To Area.Count
                Cells(ROut, Index + 3) = WorksheetFunction.Small(Area, Index)
            Next Index
            RSta = RInp
        End If
    Next RInp
End Sub

>ID登録できず、再度IDを取得しました。
という事は、変身を書けないという事ですね。質問をやり直した方がいいです。締めきれないのは仕方ないですが、ここに問い合わせた方がいいです。
https://support.yahoo-net.jp/form/s/PccChiebukuro

不適切な内容が含まれている可能性があるため、非表示になっています。

投稿内容に関する注意

ixb********さん

2020/7/511:20:24

>tra********さん


utm********で投稿したものです。
お早い回答ありがとうございます。
初めてyahoo知恵袋を使いましたが、うまくID登録できず、再度IDを取得しました。

質問ですが、指摘のとおり、添付資料が間違っていました。
今回させていただいた添付のとおり、いくつか金額をもっているが、すべてを横に記載して、かつ昇順に並べていきたいです。

また、IDが変わってしまったので、別の質問を立てればお礼させていただけるのでしょうか。

&gt;tra********さん

 
utm********で投稿したものです。...

プロフィール画像

カテゴリマスター

tra********さん

2020/7/510:22:35

Sub 一例です()
Dim APP, sh As Worksheet
Dim i As Long, ii As Long, j As Long
Set APP = Application
APP.ScreenUpdating = False
With Worksheets
Set sh = .Add(after:=.Item(.Count))
With .Item("Sheet1")
.Rows(1).Copy
sh.Rows(1).PasteSpecial
sh.Rows(1).PasteSpecial xlPasteColumnWidths
j = 1
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
ii = APP.CountIf(.Columns(1), .Cells(i, 1).Value)
j = j + 1
.Cells(i, 4).Resize(ii).Copy
sh.Cells(j, 4).PasteSpecial Transpose:=True
.Cells(i, 1).Resize(, 3).Copy sh.Cells(j, 1)
i = i + ii - 1
Next i
End With
End With
sh.Cells(1, 1).CurrentRegion.Borders.LineStyle = True
APP.ScreenUpdating = True
End Sub

>金額は順不同なため、昇順に転記していきたいです。
よく解らないです。
少なくとも、お示しの画像は金額の昇順にはなってないですね。

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

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

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

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

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

閉じる

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

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

閉じる