«Операция поиска и слияния»: VBA

Question

Я пытался собрать вместе макрос, который объединит несколько файлов .CSV.Однако данные, которые мне нужны в указанном файле (данные GPS), расположены в разных строках столбца А. Для этого они нужны для поиска части строки, в этом случае есть несколько строк, связанных с GPS, но мне нужно толькоШирота и долгота GPS (которые всегда будут найдены один за другим).

Любая помощь приветствуется!Код может выглядеть немного ... как дерьмо, я пытался возиться с ним, чтобы заставить его работать вместе!

Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim directory As Object
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Dim S_Lat, S_Long, D_Lat, D_Long As Range




Dim i As Integer
Dim icount As Integer
Dim icount2 As Integer



Application.ScreenUpdating = False
Application.DisplayAlerts = False

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show = -1 Then '-1 = yes or true
        FolderPath = .SelectedItems(1) & "\"
        Else
        MsgBox "FilePath not selected!", , "Path selecter"
        Exit Sub
    End If

End With
' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)


' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 2

' Call Dir the first time, pointing it to all .csv files in the folder path.
FileName = dir(FolderPath & "*.csv")


SummarySheet.Range("A1") = "Filnamn"
SummarySheet.Range("B1") = "Latitud"
SummarySheet.Range("C1") = "Longitud"



' Loop until Dir returns an empty string.
Do While FileName <> ""

    ' Open a workbook in the folder
    Set WorkBk = Workbooks.Open(FolderPath & "\" & FileName)

    ' Set the cell in column A to be the file name.
    SummarySheet.Range("A" & NRow).Value = FileName

    ' Set the source range to be A9 through C9.
    ' Modify this range for your workbooks.
    ' It can span multiple rows.

    For i = 1 To 200
        If InStr(1, LCase(Range("A" & i)), "GPS Latitude") <> 0 Then 'If GPS appears in the string then
            icount = i
            icount2 = icount + 1

            Set S_Lat = WorkBk.Worksheets(1).Range("A" & icount) ' Set the S_Lat variable
            Set S_Long = WorkBk.Worksheets(1).Range("A" & icount2) ' Set the S_Long variable

            Exit For

        End If
    Next i








    ' Set the destination range to start at column B and
    ' be the same size as the source range.

   '  SummarySheet.Range("B" & NRow).Value = S_Lat.Value  ***** Didnt work? ******
   '  SummarySheet.Range("C" & NRow).Value = S_Long.Value ***** Didnt work? ******

    Set D_Lat = SummarySheet.Range("B" & NRow)
    Set D_Long = SummarySheet.Range("C" & NRow)


    ' Copy over the values from the source to the destination.

    D_Lat.Value = S_Lat.Value
    D_Long.Value = S_Long.Value



    ' Increase NRow so that we know where to copy data next.
    NRow = NRow + D_Lat.Rows.Count

    ' Close the source workbook without saving changes.
    WorkBk.Close savechanges:=False

    ' Use Dir to get the next file name.
    FileName = dir()
Loop

' Call AutoFit on the destination sheet so that all
' data is readable.
' SummarySheet.Columns.AutoFit

End Sub

Answer 1

Этот простой код не дает вам полный рабочий макрос, он будет искать «Широта» в столбце А, а при обнаружении он перенесет cel.value и cel.value под ним в две строки рядом ссторона в столбце B и столбце C на одном листе.Вам нужно будет обернуть его внутри цикла Workbooks.Open, изменить диапазон в исходной рабочей таблице, включив последнюю строку, включить последнюю строку для рабочей таблицы новой рабочей книги и добавить ее в код внутри оператора If.Попробуйте включить это в свой код, и когда вы столкнетесь с проблемами, вы можете вернуться к SO и задать конкретный вопрос, касающийся вашего макроса.Макрос был протестирован с фактическими значениями долготы и широты в столбце A и рядом в столбцах B и C.

Dim lRow As Long
lRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

For Each cel In Range("A1:A38")
    If InStr(1, cel.Value, "Latitude") Then
        x = x + 1
            Cells(x, 2).Value = cel.Value
            Cells(x, 3).Value = cel.Offset(1).Value
    End If
Next cel