0

更新: サンプル ファイルサンプル ワークブック

課題：自動でできるものが欲しい

1 . 部品番号とリビジョンを検索します。「PART NUMBER」と「REVISION」を含むセルが見つかった後、2 つ下のセル (オフセット 1 列) の値を取得する必要があります。

2 . 要約表の検索を続行します。

3 . 集計表を結果シートに入れる

4 . 検索を続行し、プロセスを繰り返します

がある：

  • 同じシートに複数の部品番号または 1 つだけの可能性があります
  • 開始名が「検索」のシートのみを検索する

ここに画像の説明を入力

ここに画像の説明を入力

最初の画像はファイルの構造を示し、2 番目の画像は結果を示しています。

これが実行可能である場合、これは非常に役立ちます。私を助けてください。

更新 1: 私が考えるロジック: 1. 「SEARCH」という名前で始まるすべてのシートを検索するモジュールを作成します。

  1. ステップ 1 の結果の各シートに移動します。.NEXT で PART NUMBER と REVISION を検索して、すべての部品番号名とリビジョンを取得します (オフセット (0,1) によるアドレス指定)。

  2. 集計表の検索を開始 ==> ややこしいところへ

4

2 に答える 2

2

うわー、これは私がこの厄介なことをたくさんしなければならなかった時代に私を戻します!

とにかく、私はあなたが望むものを得るいくつかのコードを書きました。私はあなたが思っているのとは違うアプローチを取っているかもしれませんが、似たようなものだと思います。

仮定

PART NUMBER は常に列 B にあります

REVISION は常に列 F にあります

元のデータに対して他のすべての参照を再確認してください。私はあなたのワークブックにアクセスできませんでした (職場のセキュリティのため)、あなたのスクリーンショットに基づいて独自のブックを作成しました)。

Option Explicit

Sub wowzer()

Dim wks As Worksheet, wksResult As Worksheet

'set up results sheet
Set wksResult = Worksheets.Add(After:=Worksheets(Worksheets.Count))
With wksResult
    .Name = "Results"
    .Range("A1:F1") = Array("Part", "Rev", "Name", "Category", "TotalA", "TotalB")
End With

'loop through sheets to get data over
For Each wks In Worksheets

    If Left(wks.Name, 6) = "Search" Then ' does sheet start with search?

        With wks

            Dim rngFindPart As Range, rngFindName As Range

            Set rngFindPart = .Columns(2).Find("PART NUMBER", lookat:=xlWhole, After:=.Range("B" & .Rows.Count))
            Set rngFindName = .Columns(2).Find("NAME", lookat:=xlWhole, After:=.Range("B" & .Rows.Count))

            Dim strFrstAdd As String
            strFrstAdd = rngFindPart.Address 'used as a check for when we loop back and find first "PART NUMBER" again

            If Not rngFindPart Is Nothing Or Not rngFindName Is Nothing Then
            'not going to do anything if no PART NUMBER or NAME found

                Do

                    Dim rngMove As Range

                    'copy table and place it in result sheet
                    Set rngMove = .Range(rngFindName.Offset(1).Address, rngFindName.End(xlToRight).End(xlDown))
                    rngMove.Copy wksResult.Range("C" & wksResult.Rows.Count).End(xlUp).Offset(1)

                    'place part and revision, aligned with table (will de-duplicate later)
                    With wksResult
                        .Range(.Range("A" & .Rows.Count).End(xlUp).Offset(1), .Range("A" & .Rows.Count).End(xlUp).Offset(2)) = rngFindPart.Offset(1)
                        .Range(.Range("B" & .Rows.Count).End(xlUp).Offset(1), .Range("B" & .Rows.Count).End(xlUp).Offset(2)) = rngFindPart.Offset(1, 4)
                    End With

                    'find next instance of "PART NUMBER" and "NAME"
                    Set rngFindPart = .Columns(2).Find("PART NUMBER", lookat:=xlWhole, After:=rngFindPart)
                    Set rngFindName = .Columns(2).Find("NAME", lookat:=xlWhole, After:=rngFindPart)

                'done when no part number exists or it's the first instance we found
                Loop Until rngFindPart Is Nothing Or rngFindPart.Address = strFrstAdd

            End If

        End With

    End If

Next

'de-duplicate results sheet
With wksResult

    'if sheet is empty do nothing
    If .Cells(2, 1) <> vbNullString Then

        .UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlYes

    End If

End With


End Sub
于 2012-06-01T17:40:03.543 に答える
1

これはあなたがしようとしていることですか？

ここに画像の説明を入力

コード

Option Explicit

Const SearchString As String = "PART NUMBER"

Dim wsO As Worksheet, WsI1 As Worksheet, WsI2 As Worksheet
Dim lRow As Long

Sub Sample()
    Set wsO = Sheets("Result")
    Set WsI1 = Sheets("SEARCH PAGE1")
    Set WsI2 = Sheets("SEARCH PAGE2")

    lRow = 2

    PopulateFrom WsI1
    PopulateFrom WsI2
End Sub

Sub PopulateFrom(ws As Worksheet)
    Dim aCell As Range, bCell As Range, cCell As Range, nmRng As Range, cl As Range
    Dim i As Long
    Dim ExitLoop As Boolean

    With ws
        Set aCell = .Cells.Find(What:=SearchString, LookIn:=xlValues, _
                    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            Set bCell = aCell
            wsO.Range("A" & lRow).Value = aCell.Offset(1).Value
            wsO.Range("B" & lRow).Value = aCell.Offset(1, 3).Value
            i = 1
            Do
                If aCell.Offset(i) = "NAME" Then
                    Set nmRng = .Range(aCell.Offset(i), aCell.Offset(i).End(xlDown))
                     For Each cl In nmRng
                        If cl.Value <> "NAME" Then
                            If wsO.Range("A" & lRow).Value = "" Then
                                wsO.Range("A" & lRow).Value = wsO.Range("A" & lRow - 1).Value
                                wsO.Range("B" & lRow).Value = wsO.Range("B" & lRow - 1).Value
                            End If

                            wsO.Range("C" & lRow).Value = cl.Value
                            wsO.Range("D" & lRow).Value = cl.Offset(, 1).Value
                            wsO.Range("E" & lRow).Value = cl.Offset(, 2).Value
                            wsO.Range("F" & lRow).Value = cl.Offset(, 3).Value
                            lRow = lRow + 1
                        End If
                     Next
                    Exit Do
                End If
                i = i + 1
            Loop

            Do While ExitLoop = False
                Set aCell = .Cells.FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bCell.Address Then Exit Do
                    wsO.Range("A" & lRow).Value = aCell.Offset(1).Value
                    wsO.Range("B" & lRow).Value = aCell.Offset(1, 3).Value
                    i = 1
                    Do
                        If aCell.Offset(i) = "NAME" Then
                            Set nmRng = .Range(aCell.Offset(i), aCell.Offset(i).End(xlDown))
                             For Each cl In nmRng
                                If cl.Value <> "NAME" Then
                                    If wsO.Range("A" & lRow).Value = "" Then
                                        wsO.Range("A" & lRow).Value = wsO.Range("A" & lRow - 1).Value
                                        wsO.Range("B" & lRow).Value = wsO.Range("B" & lRow - 1).Value
                                    End If
                                    wsO.Range("C" & lRow).Value = cl.Value
                                    wsO.Range("D" & lRow).Value = cl.Offset(, 1).Value
                                    wsO.Range("E" & lRow).Value = cl.Offset(, 2).Value
                                    wsO.Range("F" & lRow).Value = cl.Offset(, 3).Value
                                    lRow = lRow + 1
                                End If
                             Next
                            Exit Do
                        End If
                        i = i + 1
                    Loop
                Else
                    ExitLoop = True
                End If
            Loop
        End If
    End With
End Sub

サンプルファイル

i.minus.com/1338702873/20yZJWFxgv9Egtd4klNOBg/dtst1Y4ckv86f/Sample.xlsm

于 2012-06-02T05:49:05.510 に答える