EXCEL VBA Выберите файл и найдите в первой строке ключевые слова, а затем скопируйте столбец в другой файл. - PullRequest
Новая
       17

EXCEL VBA Выберите файл и найдите в первой строке ключевые слова, а затем скопируйте столбец в другой файл.

0 голосов
/ 30 марта 2020

У меня следующая проблема.

Я хочу выбрать папку с несколькими файлами .xlsx. L oop через файлы и открыть их. Поиск в первой строке по ключевым словам, и если найдено одно из этих ключевых слов. Скопируйте весь столбец, заполненный данными, на лист с ключом в качестве имени листа и первым столбцом всех данных. ThisWorkbook.Sheet("KEYWORD")

У меня есть следующий код, но для меня, как для абсолютного новичка, все сложнее с кодированием в целом. 


Sub FINDandCopy()

With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With


    Dim FirstAddress As String
    Dim MyArr As Variant
    Dim Rng As Range
    Dim Rcount As Long
    Dim I As Long
    Dim NewSh As Worksheet
    Dim SHINDEX As String


File = Application.GetOpenFilename
File_Name = Dir(File)

Workbooks.Open Filename:=File


With ThisWorkbook.Worksheets

       .Add(After:=Sheets(Sheets.Count)).Name = File_Name

End With

    'MyArr = Array("Banana")
    MyArr = Array("I51", "I54", "I55", "I57", "I58")

   Range("A:A").Copy ThisWorkbook.Sheets(File_Name).Range("A:A")

    With Worksheets(1).Rows(1)

        Rcount = 0

        For I = LBound(MyArr) To UBound(MyArr)

            Set Rng = .Find(What:=MyArr(I), _
                            After:=.Cells(.Cells.Count), _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)

            If Not Rng Is Nothing Then

                FirstAddress = Rng.Address

                Do

                    Rcount = Rcount + 1
                    Range(Rng, Sheets(1).Cells(Rows.Count, Rng.Column).End(xlDown)).Copy ThisWorkbook.Sheets(File_Name).Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)


                    Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
            End If
        Next I
    End With

Workbooks(2).Close
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
MsgBox "Complete"
End Sub

Мои ключевые слова находятся в массиве (I51, ....) и они являются частью заголовка fe (I51.RhValue).

Последняя ошибка была изменена:

От:

Range(Rng, Sheets(1).Cells(Rows.Count, Rng.Column).End(xlUp))

до

Range(Rng, Sheets(1).Cells(Rows.Count, Rng.Column).End(xlDown))

решено Благодаря SJR!

Спасибо, Даниэль!

1 Ответ

0 голосов
/ 30 марта 2020

Можете попробовать? Я предполагаю, что вы хотите, чтобы результаты, вставленные по всему листу (в столбцах), были больше, чем вниз (по строкам).

Вы были там, просто нужно скопировать весь столбец, когда заголовок найден. 

Sub FINDandCopy()

Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim Rcount As Long
Dim I As Long
Dim NewSh As Worksheet

strDatei = Application.GetOpenFilename

If strDatei <> False Then

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

MyArr = Array("I51", "I54", "I55", "I57", "I58")

With Sheets(1).Rows(1) 'shoud add a workbook reference as working with more than one file
    For I = LBound(MyArr) To UBound(MyArr)
        Set Rng = .Find(What:=MyArr(I), _
                        After:=.Cells(.Cells.Count), _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            FirstAddress = Rng.Address
            Do
                Range(Rng, Sheets(1).Cells(Rows.Count, Rng.Column).End(xlUp)).Copy ThisWorkbook.Sheets(MyArr(I)).Cells(1, columns.Count).end(xltoleft).offset(,1)
                Set Rng = .FindNext(Rng)
            Loop While Rng.Address <> FirstAddress
        End If
    Next I
End With

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

End Sub
...