Блог

У меня есть открытая книга, в которой есть множество макросов, один из этих макросов заключается в копировании данных из этой книги и вставке их в другую книгу на сервере. Пока я могу открыть серверную книгу и перейти к правой вкладке и ячейке, но я не могу вставить данные… Мой код приведен ниже:

 Sub aggregate()
    Dim m As String
    Dim t As Integer

    'opened workbook
    Sheets("Month Count").Select
    range("A2").Select

    Do
        m = ActiveCell.Value
        t = ActiveCell.Offset(0, 1).Value

        Set xl = CreateObject("Excel.Application")
        Set xlwbook = xl.Workbooks.Open("\LOCATIONOFOTHERWORKBOOKONSERVER")
        xl.Visible = True

        xlwbook.Worksheets("A").range("A2").Select
        xlwbook.ActiveCell.Value = m **this is where my code breaks.**
        xlwbook.ActiveCell.Offset(1, 0).Value = t

        'HOW TO SAVE FILE AND CLOSE FILE?    

        Windows("GOBACKTOFIRSTWORKBOOK").Activate
        ActiveCell.Offset(1, 0).Select
    Loop Until ActiveCell.Value = "THE END"
End Sub
  

Что-то вроде приведенного ниже, которое найдет диапазон от A2 до ячейки, содержащей «КОНЕЦ» в столбце A листа под названием «Количество месяцев» в ActiveWorbook, затем откройте вторую книгу (я использовал C:testother.xlsm" , перейдите на лист «A», а затем поместите

• A2 из первой книги в A2 второй книги,
• B2 из первой книги в A3 во второй книге,
• Формат А3 из первой книги в формат А4 во второй книге,
• B3 из первой книги в A5 во второй книге и т. Д

Обратите внимание, что в вашем коде вы в настоящее время открываете новый экземпляр Excel, вы должны работать с обеими книгами в одном экземпляре, чтобы они могли «общаться»

 Sub aggregate()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim lngRow As Long
Dim lngCalc As Long

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

Set Wb1 = ActiveWorkbook
Set ws1 = Wb1.Sheets("Month Count")
Set rng1 = ws1.Columns("A").Find("THE END", , xlValues, xlWhole)

If rng1 Is Nothing Then
    MsgBox "Did not find marker cell"
    GoTo QuickExit
End If

Set rng1 = ws1.Range(ws1.[a2], ws1.Cells(rng1.Row, "A"))
Set Wb2 = Workbooks.Open("C:testother.xlsm")
Set ws2 = Wb2.Sheets("A")
For Each rng2 In rng1
    ws2.[a2].Offset(lngRow, 0) = rng2
    ws2.[a2].Offset(lngRow   1, 0) = rng2.Offset(0, 1)
    lngRow = lngRow   2
Next
Wb2.Save
Wb2.Close
Wb1.Activate


QuickExit:

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

End Sub
  

1. нет смысла «активировать» ваши книги.
2. вам не нужно создавать экземпляр второго Excel, если ваш макрос уже запущен в Excel.
3. это было бы намного быстрее сделать одним выстрелом
4. Я подозреваю, что ваша ошибка связана с тем, что xlwbook не была активирована при использовании xlwbook.ActiveCell .

Ниже мое предложение для вашего копирования / вставки, один за другим (или я должен сказать 2 на 2).

     Sub aggregate2()
    Dim rngSource As Range
    Dim rngDest As Range
    Dim xlwbook As Workbook

    Set rngSource = Sheets("Month Count").Range("A2:B2")

    Set xlwbook = Workbooks.Open("\LOCATIONOFOTHERWORKBOOKONSERVER")
    Set rngDest = xlwbook.Range("A2:B2")

    Do
        rngDest.Value = rngSource.Value
        Set rngSource = rngSource.Offset(1, 0)
        Set rngDest = rngDest.Offset(1, 0)
    Loop Until rngDest.Cells(1, 1) = "THE END"  
    xlwbook.close
    End Sub