Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Копирование диапазоны данных в рамках цыкла
 
Добрый день, Друзья

Описание кода:
1) Проверяет есть ли ошибки в диапазоне данных S10:S500 на листе "Лист1"
2) Просматривает диапазон данных S10:S500 на листе "Лист1" и выбирает только уникальные значения, записывает на этот же лист в ячейку начиная с "C10".
3) После проверки данных копирует все данные c листа "Лист1"  данные из диапазона I10:R500 и вставляем на лист "Order" в ячейки A2:J2

Подскажите как исправить код, что бы 3-й пункт реализации кода всё таки заработал.


Код
'--------------------------------------------------------------------------

Sub MassUnique()
    Dim myArr(), MassUnique()
    Dim cl As Range
    Dim ShtR As Worksheet
    Dim ShtA As Worksheet
    Dim S As Long
    Dim B As Long
    Dim A As Long
    Dim C As Long
    Set ShtR = Workbooks("mail.xlsm").Worksheets("Order")
    ShtR.Range("A2:J500" & WorksheetFunction.Max(4, ShtR.Cells(ShtR.Rows.Count, 1).End(xlUp).Row)).Value = "" 
    S = 1

    With Worksheets("Лист1")
            myArr = .Range("S10:S500" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
            For Each cl In .Range("S10:S500" & .Cells(.Rows.Count, 1).End(xlUp).Row)
                If IsError(cl) Then
                    MsgBox "Текст сообщения""Текст""", vbExclamation + vbOKCancel
                    Exit Sub
                   C = ShtA.Cells(.Rows.Count, 1).End(xlUp).Row
                    If C > 0 Then
                        For A = 1 To C
                          S = S + 1
                          ShtR.Cells(S, 1).Resize(1, 2).Value = .Range(.Cells(A, 10), .Cells(A, 11)).Value
                          ShtR.Cells(S, 3).Resize(1, 2).Value = .Range(.Cells(A, 12), .Cells(A, 13)).Value
                          ShtR.Cells(S, 5).Resize(1, 2).Value = .Range(.Cells(A, 14), .Cells(A, 15)).Value
                          ShtR.Cells(S, 7).Resize(1, 2).Value = .Range(.Cells(A, 16), .Cells(A, 17)).Value
                          ShtR.Cells(S, 9).Resize(1, 1).Value = .Range(.Cells(A, 18), .Cells(A, 18)).Value
                        Next A
                    End If
                End If
            Next
            '----------------
    End With

        MassUnique = UniqueValuesFromArray(myArr, 1)
        ActiveSheet.Range("C10").Resize(UBound(MassUnique)) = MassUnique
End Sub

Sub MassClear()
     Range("C10:C96").ClearContents 
End Sub
'---------------------------------------------------------------------------------------

Function UniqueValuesFromArray(ByVal Arr, ByVal col As Long) As Variant
Dim i As Integer

    If Not IsArray(Arr) Then MsgBox "Текст сообщения!", vbCritical: Exit Function
    If col > UBound(Arr, 2) Then MsgBox "Текст сообщения!", vbCritical: Exit Function
    If col < LBound(Arr, 2) Then MsgBox "Текст сообщения!", vbCritical: Exit Function

    On Error Resume Next: Dim coll As New Collection, txt$
    For i = LBound(Arr) To UBound(Arr)
         txt$ = Trim(Arr(i, col)): coll.Add txt$, txt$
    Next i
    ReDim newarr(1 To coll.Count, 1 To 1)
    For i = 1 To coll.Count: newarr(i, 1) = coll(i): Next i
    UniqueValuesFromArray = newarr
End Function
 
Добрый день. А как вы себе представляете вставку массива данных 490 строк на 9 столбцов в диапазон размером в одну (!) строку и 10 столбцов?
Кому решение нужно - тот пример и рисует.
 
Пытливый,
Может быть я не корректно обозначил диапазоны откуда копируем и куда вставляем.

Проверяем диапазон I10:R500 на предмет последней записи (нужно вставить только заполненные строки) копируем и вставляем в диапазон A2:J500 (только найденные значения).
 
И макрос "MassUnique" и переменная "MassUnique"... Как Вас еще VBE не забанил...
Так и выгружайте полученный массив уникальных на нужный лист.
Код
Sheets("Order").Range("A2").Resize(UBound(MassUnique,1), Ubound(MassUnique,2)) = MassUnique
 
Anchoret,
Спасибо за пример но в моём случае нужно перенести таблицу с одного листа без изменений на другой лист.
 
Цитата
Mutarix написал:
без изменений на другой лист
Вы же собирались переносить туда только уникальные значения. Отформатирйте диапазон во втором файле.
 
Anchoret,
В начале письма я описал функционал кода который реализован.
Первые два пункта реализованы и они не пересекаются с реализацией третьего пункта.
Третий пункт нужно реализовать отдельно.
То есть полученные данные которые находятся в диапазоне I10:R500 проверяем на предмет последней записи копируем и вставляем в диапазон A2:J500 (только найденные значения).
 
Не знаю что имеется ввиду под "найденными значениями".
Исправляйте:
Код
myArr = .Range("S10:S" & .UsedRange.Rows.Count).Value
For Each cl In .Range("S10:S" & .UsedRange.Rows.Count)
Варианты переноса данных. Первый массивом, второй (закомментированный) - полный перенос.
Код
Set aa = Worksheets("Лист1").Range("I10:R500")
arr = aa.Value
ShtR.Range("A2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
'aa.copy ShtR.[A2]
Изменено: Anchoret - 2 Мар 2018 10:31:07
 
Anchoret,
Большое спасибо код работает в составе следующего макроса

Sub MassUnique()
   Dim myArr(), MassUniqueF(), arr()
   Dim cl As Range
   Dim ShtR As Worksheet
   Dim aa As Range
   Set ShtR = Workbooks("mail.xlsm").Worksheets("Order")
   ShtR.Range("A2:J500" & WorksheetFunction.Max(4, ShtR.Cells(ShtR.Rows.Count, 1).End(xlUp).Row)).Value = ""
   Set aa = Worksheets("Main").Range("I10:R500")

   With Worksheets("Main")
         myArr = .Range("S10:S" & .UsedRange.Rows.Count).Value
           For Each cl In .Range("S10:S" & .UsedRange.Rows.Count)
               If IsError(cl) Then
                   MsgBox "текст сообщения ", vbExclamation + vbOKCancel
                   Exit Sub
               End If
           Next
                   arr() = aa.Value
                   ShtR.Range("A2").Resize(UBound(arr(), 1), UBound(arr(), 2)) = arr() ' копирует данные без форматирования
                  '  aa.Copy ShtR.[A2] - если нужно скопировать весь диапазон с форматированием

   End With
       MassUniqueF = UniqueValuesFromArray(myArr, 1)
       ActiveSheet.Range("C10").Resize(UBound(MassUniqueF)) = MassUniqueF
End Sub


Задача решена.
Изменено: Mutarix - 14 Мар 2018 18:36:18
Страницы: 1
Читают тему (гостей: 1)