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

Помогите макросом, задача которого при нажатии на кнопку SAVE заключается в копирование данных с листа "Info" столбец "B" и вставить данные на лист "AMLTable" начиная со строки А2. При повторном нажатии на кнопку, данные на листе "AMLTable" не перезаписывались, а дополнялись.

Заранее благодарю.
 
как-то так
Код
Sub cmdSave()
    Dim r As Integer, rmax As Long
    Dim ShF As Worksheet, ShT As Worksheet
    
    Set ShF = ThisWorkbook.Sheets("Info")
    Set ShT = ThisWorkbook.Sheets("AMLTable")
    
    rmax = ShT.Cells(ShT.Rows.Count, 1).End(xlUp).Row + 1
    For r = 5 To 21
        If r < 15 Then ShT.Cells(rmax, r - 4) = ShF.Cells(r, 2)
        If r > 15 Then ShT.Cells(rmax, r - 5) = ShF.Cells(r, 2)
    Next r
End Sub
 
webley,спасибо!
 
Здравствуйте,

У меня еще одна просьба, можно ли слегка подкорректирвоать код, чтоб там стояла проверка на повтор, то есть после нажатия кнопки "SAVE" он сверяет Type code со страницы "Info" cо с Type code на странице "AMLTable" и если кода совпали, то перезаписывает строчку, если нет, создает новую

Заранее благодарю за помощь
Изменено: oggis - 30 Июл 2017 11:52:16
 
Код
Sub test()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim rowcnt&, arr(), msg$, cell As Range
Set sht1 = Sheets("Info")
Set sht2 = Sheets("AMLTable")
rowcnt = sht2.Cells(sht2.Rows.Count, 1).End(xlUp).Row + 1
With sht1
    msg = .Cells(6, 2).Value
    arr = .Range("b5:b21").Value
End With
sht2.Columns(2).NumberFormat = "@"
Set cell = sht2.Columns(2).Find(msg)
If Not cell Is Nothing Then
    Range("a" & cell.Row).Resize(, UBound(arr)) = Application.Transpose(arr)
Else
     Range("a" & rowcnt).Resize(, UBound(arr)) = Application.Transpose(arr)
End If
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Код
Sub cmdSave()
    Dim r As Integer, rmax As Long
    Dim ShF As Worksheet, ShT As Worksheet
     
    Set ShF = ThisWorkbook.Sheets("Info")
    Set ShT = ThisWorkbook.Sheets("AMLTable")
    
    On Error Resume Next
        rmax = Application.WorksheetFunction.Match(ShF.Cells(6, 2), ShT.Columns(2), 0)
    On Error GoTo 0
    If rmax = 0 Then rmax = ShT.Cells(ShT.Rows.Count, 1).End(xlUp).Row + 1
    
    For r = 5 To 21
        If r < 15 Then ShT.Cells(rmax, r - 4) = ShF.Cells(r, 2)
        If r > 15 Then ShT.Cells(rmax, r - 5) = ShF.Cells(r, 2)
    Next r
End Sub
 
Nordheim, webley, спасибо!
 
Уважаемые форумчане!

Вот уже почти год пользуемся вашим решением, спасибо вам еще раз за помощь. Но спустя время форма шаблона немного изменилась и теперь информация на обоих листах в горизонтальном формате (не получается загрузить файл, все зависает на 90%, размер файла 15кб). Можно подкорректировать код, чтоб он копировал данные строчки, а не столбца? Остальные условия те же:

Цитата
oggis написал:
чтоб там стояла проверка на повтор, то есть после нажатия кнопки "SAVE" он сверяет Type code со страницы "Info" cо с Type code на странице "AMLTable" и если кода совпали, то перезаписывает строчку, если нет, создает новую

Спасибо большое за помощь!
Изменено: oggis - 17 Апр 2018 10:11:13
 
15К должны вообще без проблем загрузиться. Попробуйте ещё раз.
 
Получилось загрузить файл пример из дома
 
Напишите что нужно сделать поконкретней. По файлу вижу на одном листе таблица на другом заголовки, что нужно куда переносить?
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, При нажатие кнопки SAVE нужно копировать строки со страницы "Info" на страницу "AML Table", при копировании сверять Type Code со страницы "Info" со Type Code на странице "AML Table", и если кода совпали, то перезаписывать строчку, если нет, то создать новую.
 
Скрытый текст
Изменено: Nordheim - 18 Апр 2018 09:12:57
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, спасибо Вам, что откликнулись! Во время работы макроса, заметил, что при первом запуске он обрабатывает только первые три строки, но при повторном уже обрабатывает все нормально. Не знаете в чем может быть проблема?
Изменено: oggis - 18 Апр 2018 22:11:45
 
Замените строку
Код
If Not IsEmpty(larr(1, 1)) Then .Range("a" & i).Resize(i, UBound(larr, 2)).Value = larr

на
Код
If Not IsEmpty(larr(1, 1)) Then .Range("a" & i).Resize(x, UBound(larr, 2)).Value = larr
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, спасибо большое!
 
Уважаемые форумчане!
Обращаюсь к Вам снова за помощью. Можно ли изменить нижеуказанный код так, чтоб он брал информацию с первого листа, 4 столбца и сверял ее со вторым листом и столбцом номер 7.
Остальной функционал макроса остается точно таким же.
Код
Sub update()
    Dim arr(), iarr(), x&
    Dim i&, j&, dic As New Scripting.Dictionary
    With Sheet1
        arr = .Range(.[a5].End(xlToRight), .[a5].End(xlDown)).Value
    End With
    With Sheet2
        iarr = .Range(.[a2].End(xlToRight), .[a2].End(xlDown)).Value
    End With
    For i = 2 To UBound(iarr)
        dic.Item(CStr(iarr(i, 2))) = i
    Next i
    ReDim larr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 2 To UBound(arr)
        If Not dic.Exists(CStr(arr(i, 2))) Then
            x = x + 1
            For j = 1 To UBound(arr, 2): larr(x, j) = arr(i, j): Next j
        Else: For j = 1 To UBound(arr, 2): iarr(dic.Item(CStr(arr(i, 2))), j) = arr(i, j): Next j
        End If
    Next i
    With Sheet2
        .Columns(2).NumberFormat = "@"
        .[a2].Resize(UBound(iarr), UBound(iarr, 2)).Value = iarr
        i = .Range("a" & .Rows.Count).End(xlUp).Row + 1
        If Not IsEmpty(larr(1, 1)) Then .Range("a" & i).Resize(x, UBound(larr, 2)).Value = larr
    End With
End Sub

Заранее спасибо!
Изменено: oggis - 19 Ноя 2019 15:41:46
 
Может кто-нибудь сможет помочь?
 
Я начал сам пробовать изменить его и к сожалению на строчке
Код
With Sheet2        iarr = .Range(.[a5].End(xlToRight), .[a5].End(xlDown)).Value
макрос дает ошибку Overflow ((

По задумке, макрос должен сверять значения в столбце 59 на первом листе со вторым листои и так же столбцом номер 59 и если кода совпали, то перезаписывать строчку, если нет, то создать новую.
Код
Sub baseupd59()
    Dim arr(), iarr(), x
    Dim i, j, dic As New Scripting.Dictionary
    With Sheet1
        arr = .Range(.[a5].End(xlToRight), .[a5].End(xlDown)).Value
    End With
    With Sheet2
        iarr = .Range(.[a5].End(xlToRight), .[a5].End(xlDown)).Value
    End With
    For i = 2 To UBound(iarr)
        dic.Item(CStr(iarr(i, 59))) = i
    Next i
    ReDim larr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 2 To UBound(arr)
        If Not dic.Exists(CStr(arr(i, 59))) Then
            x = x + 1
            For j = 1 To UBound(arr, 59): larr(x, j) = arr(i, j): Next j
        Else: For j = 1 To UBound(arr, 2): iarr(dic.Item(CStr(arr(i, 59))), j) = arr(i, j): Next j
        End If
    Next i
    With Sheet2
        .Columns(59).NumberFormat = "@"
        .[a2].Resize(UBound(iarr), UBound(iarr, 2)).Value = iarr
        i = .Range("a" & .Rows.Count).End(xlUp).Row + 1
        If Not IsEmpty(larr(1, 1)) Then .Range("a" & i).Resize(i, UBound(larr, 2)).Value = larr
    End With
End Sub

Помогите пожалуйста
 
Приложите файл пример поподробней как есть и как нужно, возможно код будет написан иной. Даже мне сложно разобраться и вспомнить что я писал, в 2018 году
Изменено: Nordheim - 23 Ноя 2019 15:39:57
"Все гениальное просто, а все простое гениально!!!"
 
Возможно так заработает

Код
Sub main()
 Dim arr(), iarr(), x&
    Dim i&, j&, dic As New Scripting.Dictionary
    With Лист1
        arr = .Range(.[a5].End(xlToRight), .[a5].End(xlDown)).Value
    End With
    With Лист2
        iarr = .Range(.[a2].End(xlToRight), .[a2].End(xlDown)).Value
    End With
    For i = 2 To UBound(iarr)
        dic.Item(CStr(iarr(i, 4))) = i
    Next i
    ReDim larr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 2 To UBound(arr)
        If Not dic.Exists(CStr(arr(i, 7))) Then
            x = x + 1
            For j = 1 To UBound(arr, 2): larr(x, j) = arr(i, j): Next j
        Else: For j = 1 To UBound(arr, 2): iarr(dic.Item(CStr(arr(i, 2))), j) = arr(i, j): Next j
        End If
    Next i
    With Sheet2
        .Columns(2).NumberFormat = "@"
        .[a2].Resize(UBound(iarr), UBound(iarr, 2)).Value = iarr
        i = .Range("a" & .Rows.Count).End(xlUp).Row + 1
        If Not IsEmpty(larr(1, 1)) Then .Range("a" & i).Resize(x, UBound(larr, 2)).Value = larr
    End With
End Sub
"Все гениальное просто, а все простое гениально!!!"
Страницы: 1
Читают тему (гостей: 1)
Наверх