Мне нужно извлечь ревизии из разных листов в разных книгах. Каждый документ имеет разное количество ревизий, как мне это сделать?

Question

Я подумал, что должен перефразировать мой вопрос.Вот что я пытаюсь сделать и что я сделал до сих пор: Шаги:

1. Открыть выбранные файлы (ГОТОВО)
2. Получить номер файла.(СОВЕРШЕНО)
3. Получить ревизию файла.(СОВЕРШЕНО)
4. Найдите ячейки, в которых запись начинается с 27 и обычно содержит буквы после, например, 27A, 27B, 27C ..... 27AB, 27AC, 27AD, ... 27XXX.(Проблема в том, что ячейка содержит что-то вроде «27AB. Некоторые предложения и т.
5. Когда будет достигнут последний 27ХХХ, прекратите это делать.

Последние три части - это то, где я застрял.

'SELECT REQUIRED WORKBOOKS

Dim fileNames As Variant
Application.ScreenUpdating = False 'does not show the windows opening
Application.DisplayAlerts = False
Range("A2").Select
fileNames = Application.GetOpenFilename(Title:="Open File(s)", 
MultiSelect:=True)

'OBTAIN Number AND REV FROM COVER PAGE OF Document

For i = 1 To UBound(fileNames)
Workbooks.Open fileNames(i)
Sheets(1).Select
Range("E4", "F4").Select
Selection.Copy
Windows("MainFile.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=False
Workbooks.Open fileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(1, 0).Activate
Next i




End Sub

Answer 1

Ваш вопрос не очень конкретен в отношении деталей! Код ниже основан на том, что «27xyz» находится в столбце А. Куда вы хотите скопировать значения «27 ...»? Еще один лист в отдельных книгах? Или одна книга назначения?

Код обновлен на основе комментария "Вот пример файла. TheAviationist" (https://drive.google.com/file/d/1_o_bJAYLT3wQ5v8Ij0_PFQALI6v-wCVM/view?usp=sharing)

Option Explicit

Sub DoItAll()
Dim ws As Worksheet

    Call Create_a_WorkbookCopy
    Call CreateSheetStrings27
    For Each ws In Worksheets
        If ws.Name <> "Strings_27" Then
            ws.Select
            Call FilterCells
            Call CopyFilteredRows2otherWorksheet
            ws.AutoFilterMode = False
        End If
    Next ws
    Call SplitText
    '   Call DeleteAllDataSheets
    '     or
    '   Call CopyStrings27toNewWorkbook
End Sub

Sub DeleteAllDataSheets()
Dim ws As Worksheet
    For Each ws In Worksheets
        If ws.Name <> "Strings_27" Then
            Application.DisplayAlerts = False
            'Debug.Print ws.Name
            ws.Delete
            Application.DisplayAlerts = True
        End If
    Next ws
End Sub

Sub CopyStrings27toNewWorkbook()
    Sheets("Strings_27").Copy
End Sub

Sub CreateSheetStrings27()
Dim ws As Worksheet
On Error Resume Next
Sheets("Strings_27").Select
If ActiveSheet.Name <> "Strings_27" Then
    Set ws = Worksheets.Add
    ws.Name = "Strings_27"
    Sheets("Strings_27").Move Before:=Sheets(1)
End If
On Error GoTo 0
End Sub

Sub Create_a_WorkbookCopy()
Dim newFileName As String
    'create a copy of the original workbook

    If Not ThisWorkbook.Name Like "*_COPY*" Then
        newFileName = Replace(ThisWorkbook.Name, ".xls", "_COPY.xls")
        newFileName = Split(newFileName, ".")(0)
        ThisWorkbook.SaveAs newFileName, xlExcel12
    End If
End Sub

Sub FilterCells() 'This only works if there are now empty rows'
    Range("A:A").AutoFilter Field:=1, Criteria1:="27*", Operator:=xlFilterValues
End Sub

Sub RemoveFilter() 'This only works if there are now empty rows'
    'Range("A:A").AutoFilter
    ActiveSheet.AutoFilterMode = False
End Sub



Sub FilterCellsWithEmptyRows()
Dim lastRow As Long
    lastRow = Range("A1").SpecialCells(xlCellTypeLastCell).Row
    Range("A1:" & lastRow).AutoFilter Field:=1, Criteria1:="27*", Operator:=xlFilterValues
End Sub

Sub CopyFilteredRows2otherWorksheet()
Dim rng As Range
Dim ws As Worksheet
Dim lastRow As Long

If ActiveSheet.AutoFilterMode = False Then
MsgBox "There are no filtered rows"
Exit Sub
End If
Set rng = ActiveSheet.AutoFilter.Range
rng.UnMerge
lastRow = Sheets("Strings_27").Range("A1").SpecialCells(xlCellTypeLastCell).Row
If lastRow = 1 Then lastRow = -1

'Copy the sheet name
Sheets("Strings_27").Range("A1").Offset(lastRow + 1, 0).Value = ActiveSheet.Name
Sheets("Strings_27").Range("A1").Offset(lastRow + 1, 0).Font.Bold = True
Sheets("Strings_27").Range("A1").Offset(lastRow + 1, 0).Font.Size = 20
'Copy the filtered values only
rng.Copy Sheets("Strings_27").Range("A1").Offset(lastRow + 2, 0)
Sheets("Strings_27").Range("A:A").WrapText = False
End Sub

Sub CopyFilteredRows2otherWorkbook()
Dim rng As Range
Dim ws As Worksheet
Dim wb As Workbook
If Worksheets("Sheet1").AutoFilterMode = False Then
MsgBox "There are no filtered rows"
Exit Sub
End If

'The file "DestinationWorkbook.xls" must be open!
Set wb = Workbooks("DestinationWorkbook.xls")
Set rng = wb.Worksheets("Sheet1").AutoFilter.Range
Set ws = Worksheets.Add
ws.Name = "Strings_27"
rng.Copy Range("A1")
End Sub

Sub SplitText()
Dim SplitRange As Range
Dim myRange As Range
Dim lastRow As Long
Sheets("Strings_27").Select
Set SplitRange = Range("A:A") '.CurrentRegion
SplitRange.TextToColumns Destination:=SplitRange.Offset(, 1), _
    DataType:=xlDelimited, TextQualifier:=xlTextQualifierDoubleQuote, _
    ConsecutiveDelimiter:=True, Space:=True
Range("C:ZZ").ClearContents
Range("B1").Value = "1st word"
Range("B1").Font.Bold = True
Range("B1").Font.Size = 20
Range("B1").Font.Color = RGB(255, 0, 0)
Columns("B:B").Replace What:=".", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

'Format Column B = Result Column
lastRow = Sheets("Strings_27").Range("A1").SpecialCells(xlCellTypeLastCell).Row
Set myRange = Columns("A:A")
myRange.Copy
Range("B1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("B1").Font.Color = RGB(255, 0, 0)

Set myRange = Range("B1:B" & lastRow)
myRange.Interior.Color = RGB(255, 204, 204)
Columns("B:B").EntireColumn.AutoFit
Columns("B:B").HorizontalAlignment = xlCenter
Range("C1").Select
End Sub

Sub TestColor()
    Debug.Print getRGB2(Range("B2"))
End Sub

'https://stackoverflow.com/questions/24132665/return-rgb-values-from-range-interior-color-or-any-other-color-property
'= https://excelribbon.tips.net/T010180_Determining_the_RGB_Value_of_a_Color.html
Function getRGB2(rcell) As String
    Dim C As Long
    Dim R As Long
    Dim G As Long
    Dim B As Long

    C = rcell.Interior.Color
    R = C Mod 256
    G = C \ 256 Mod 256
    B = C \ 65536 Mod 256
    getRGB2 = "R=" & R & ", G=" & G & ", B=" & B & "   =RGB(" & R & ", " & G & ", " & B & ")"
End Function


Sub SplitText()
Dim SplitRange As Range
Set SplitRange = Range("A1").CurrentRegion
SplitRange.TextToColumns Destination:=SplitRange.Offset(, 1), _
    DataType:=xlDelimited, TextQualifier:=xlTextQualifierDoubleQuote, _
    ConsecutiveDelimiter:=True, Space:=True
Range("C:Z").ClearContents
Range("B1").Value = "1st word"
End Sub

.
.
.
Скриншот результата

.
.
.
Создать пример данных
Чтобы создать пример данных из листа, скопируйте эту формулу B1 или C1 и скопируйте ее в несколько строк:
= "= Диапазон (" "" & ЯЧЕЙКА ( "адрес", А1) & "" ") =" "" & A1 & "" ""

Answer 2

Option Explicit

Sub Button1_Click()

    Dim i As Long, a As Long, fileNames As Variant, ws As Worksheet
    Dim r As Range, addr As String
    ReDim arr(0) As Variant

    Set ws = ActiveSheet

    fileNames = Application.GetOpenFilename(FileFilter:="Excel Filter (*.xlsx,*.xlsx", Title:="Open File(s)", MultiSelect:=True)

    For i = LBound(fileNames) To UBound(fileNames)

        '1. Open Selected Files (DONE)
        With Workbooks.Open(Filename:=fileNames(i), ReadOnly:=True)
            With .Worksheets("sheet1")

                '2. Obtain File number. (DONE) / 3. Obtain File revision. (DONE)
                .Cells(4, "E").Copy _
                  Destination:=ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)

                '4. Look for cells where the entry starts with 27 and usually has letters after ...
                Set r = .Cells.Find(What:="27*", After:=.Cells(1), _
                                    LookIn:=xlFormulas, LookAt:=xlWhole, _
                                    SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                    MatchCase:=False, SearchFormat:=False)
                If Not r Is Nothing Then
                    addr = r.Address(0, 0)
                    Do
                        '5a. Copy cells that have 27 in them (As mentioned above) but just the first 'word' like just the 27A, or 27AB etc.
                        ReDim Preserve arr(a)
                        arr(a) = Split(r.Value2 & Space(1), Space(1))(0)
                        Set r = .Cells.FindNext(After:=r)
                    While addr <> r.Address(0, 0)
                End If

                '5b. Copy cells that have 27 in them (As mentioned above) but just the first 'word' like just the 27A, or 27AB etc.
                ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(UBound(arr) + 1, 1) = _
                  Application.Transpose(arr)

            End With
            '6. When the last 27XXX is reached, stop doing it.
            .Close savechanges:=False
        End With

    Next i
End Sub