aybek04 (Автор тем)

Область копирования, Как определять облать копирования если значения могут быть динамичны?

Пользователь

Сообщений: 85 Регистрация: 13.02.2020

27.08.2024 08:32:49

Здравствуйте Уважаемые формучане. Задача была определить область копирования и скопировать.
С чем не справляется построенный код.

Скрытый текст

Код

Sub CopyDataFromAnotherWorkbook()
    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim targetWorksheet As Worksheet
    Dim filePath As String
    Dim targetRange As Range
    Dim newSheetName As String
    Dim copySheetName As String
    Dim destinationWorksheet As Worksheet
    Dim newSheetForData As Worksheet
    Dim wsList1 As Worksheet
    Dim searchRange As Range
    Dim cell As Range
    Dim columnsToCopy As String
    Dim col As Range
    Dim filteredRange As Range
    Dim newSheetNameForData As String

    ' Очищаем данные в 1, 2 и 3 колонках начиная с 3 строки до 999 строки
    With ThisWorkbook.Sheets("Лист1")
        .Range("J2").ClearContents
        .Range("A3:A999").ClearContents
        .Range("B3:B999").ClearContents
        .Range("C3:C999").ClearContents
    End With

    ' Открываем диалоговое окно для выбора файла
    filePath = Application.GetOpenFilename("Excel Files (*.xls; *.xlsx), *.xls; *.xlsx", , "Выберите файл для копирования данных")

    ' Проверка, что файл был выбран
    If filePath <> "False" Then
        ' Открываем исходную книгу
        Set sourceWorkbook = Workbooks.Open(filePath)

        ' Предполагаем, что данные на первом листе (можно изменить, если нужно)
        Set sourceWorksheet = sourceWorkbook.Sheets(1)

        ' Имя нового листа для копирования данных
        newSheetName = "Копированные данные"

        ' Если лист с таким именем существует, удаляем его
        On Error Resume Next
        Application.DisplayAlerts = False
        ThisWorkbook.Sheets(newSheetName).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

        ' Создаем новый лист для копирования данных
        Set targetWorksheet = ThisWorkbook.Sheets.Add
        targetWorksheet.Name = newSheetName

        ' Определяем диапазон для копирования
        Set targetRange = sourceWorksheet.UsedRange

        ' Копируем только значения
        targetWorksheet.Range("A1").Resize(targetRange.Rows.Count, targetRange.Columns.Count).Value = targetRange.Value

        ' Закрываем исходную книгу без сохранения
        sourceWorkbook.Close SaveChanges:=False

        ' Ищем текст "Всего наименований" в листе
        Set searchRange = targetWorksheet.UsedRange
        For Each cell In searchRange
            If InStr(cell.Value, "Всего наименований") > 0 Then

                ' Копируем значение найденной ячейки в Лист1 J2
                ThisWorkbook.Sheets("Лист1").Range("J2").Value = cell.Value

                ' Определяем столбцы для копирования
                If InStr(cell.Value, "CNY") > 0 Then
                    columnsToCopy = "D:D,AB:AB,AK:AK"
                Else
                    columnsToCopy = "C:C,AA:AA,AJ:AJ"
                End If
                Exit For
            End If
        Next cell

        ' Имя нового листа для скопированных колонок
        copySheetName = "Копия данных"

        ' Если лист с таким именем существует, удаляем его
        On Error Resume Next
        Application.DisplayAlerts = False
        ThisWorkbook.Sheets(copySheetName).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

        ' Создаем новый лист для скопированных колонок
        Set destinationWorksheet = ThisWorkbook.Sheets.Add
        destinationWorksheet.Name = copySheetName

        ' Копируем выбранные колонки на новый лист
        targetWorksheet.Range(columnsToCopy).Copy
        destinationWorksheet.Range("A1").PasteSpecial Paste:=xlPasteValues

        ' Добавляем 0 в 4-ю колонку с 1 по 999 строку
        destinationWorksheet.Range("D1:D999").Value = 0

        ' Очищаем ячейки со значением "Количество" во второй колонке
        Set col = destinationWorksheet.Range("B1:B999") ' Вторая колонка
        For Each cell In col
            If cell.Value = "Количество" Then
                cell.ClearContents
            End If
        Next cell

        ' Применяем фильтр
        With destinationWorksheet
            .Range("$A$1:$D$999").AutoFilter Field:=2, Criteria1:="<>", Operator:=xlAnd, Criteria2:="<>"
        End With

        ' Создаем новый лист для вставки данных
        newSheetNameForData = "Отфильтрованные данные"

        ' Если лист с таким именем существует, удаляем его
        On Error Resume Next
        Application.DisplayAlerts = False
        ThisWorkbook.Sheets(newSheetNameForData).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

        ' Создаем новый лист для скопированных данных
        Set newSheetForData = ThisWorkbook.Sheets.Add
        newSheetForData.Name = newSheetNameForData

        ' Определяем отфильтрованный диапазон
        On Error Resume Next
        Set filteredRange = destinationWorksheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        If Not filteredRange Is Nothing Then
            filteredRange.Copy newSheetForData.Range("A1")
        End If

        ' Сортируем данные по первому столбцу в алфавитном порядке
        With newSheetForData
            .UsedRange.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlNo
        End With

        ' Удаляем только четвертый столбец
        newSheetForData.Columns(4).Delete

        ' Копируем данные на Лист1
        Set wsList1 = ThisWorkbook.Sheets("Лист1")
        newSheetForData.UsedRange.Copy wsList1.Range("A3")

        ' Найти последнюю заполненную ячейку в столбцах B и C
        Dim lastRowB As Long
        Dim lastRowC As Long

        lastRowB = wsList1.Cells(wsList1.Rows.Count, 2).End(xlUp).row
        lastRowC = wsList1.Cells(wsList1.Rows.Count, 3).End(xlUp).row

        ' Рассчитываем суммы в столбцах B и C
        Dim sumB As Double
        Dim sumC As Double

        sumB = Application.WorksheetFunction.Sum(wsList1.Range("B3:B" & lastRowB))
        sumC = Application.WorksheetFunction.Sum(wsList1.Range("C3:C" & lastRowC))

        ' Проверяем значение в ячейке J2
        Dim currencyType As String
        Dim conversionRate As Double

        currencyType = wsList1.Range("J2").Value

        ' Если значение в J2 содержит "CNY", умножаем сумму на значение в J3
        If InStr(1, currencyType, "CNY", vbTextCompare) > 0 Then
            conversionRate = wsList1.Range("J3").Value
            sumC = sumC * conversionRate
        End If

        ' Вставляем сумму в первую пустую ячейку под данными в столбцах B и C
                wsList1.Cells(lastRowB + 1, 2).Value = sumB
        wsList1.Cells(lastRowC + 1, 3).Value = sumC

        ' Удаляем листы "Копия данных", "Копированные данные" и "Отфильтрованные данные"
        On Error Resume Next
        Application.DisplayAlerts = False
        ThisWorkbook.Sheets(copySheetName).Delete
        ThisWorkbook.Sheets(newSheetName).Delete
        ThisWorkbook.Sheets(newSheetNameForData).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

        Application.CutCopyMode = False

        MsgBox "Данные из файла 1С успешно скопированы", vbInformation
    Else
        MsgBox "Файл не был выбран.", vbExclamation
    End If
End Sub

Счетами 734 и 1081 он справлялся
но оказалось и области копирования могут быть разными.

Подскажите как переиграть что бы можно было копировать нужные данные независимо от расположения значений

Изменено: БМВ - 27.08.2024 08:39:16

Перейти

Изменение темы письма при отправке его из Excel, удалить левые символы в наименовании файла