VBS [VBS] Скрипт передачи данных из одной книги в другую

[kirk2011]

Здравствуйте, нужен скрипт который перекидывает данные с полей одного объекта в другой(otkuda->kuda)
поля:
number postavki->№ поставки
company->фирма
rashifrovka-> наименование

 

[Dragokas]

Здравствуйте, kirk2011 !

Добро пожаловать на SafeZone !

Вопрос:
1. Если от одной и той же фирмы будут указаны разные комплектующие (например, сис. блок + ноутбук), то их нужно в одной строке записывать или в разных?
2. Эти книги всегда открыты / всегда закрыты / или состояние неопределённое ?

 

[kirk2011]

1. Можно в одной строке.
2. Закрытые

 

[kirk2011]

Главное чтобы ячейки исходника и адресата привязаны были.

 

[Dragokas]

kirk2011, сделал по-проще, без обработки дубликатов.

Option Explicit

Dim oBook1, oBook2, oExcel, sBookSource, sBookDest

sBookSource = "h:\_VBA\_Transfer\otkuda.xlsx"
sBookDest = "h:\_VBA\_Transfer\kuda.xlsx"

set oExcel = GetExcel()

'oExcel.Visible = true

set oBook1 = oExcel.Workbooks.Open(sBookSource)
set oBook2 = oExcel.Workbooks.Open(sBookDest)

call Processing(oBook1, oBook2)

oBook1.Close (false)
oBook2.Close (true)

oExcel.Quit

WScript.Echo ("finished")

Sub Processing(oBook1, oBook2)
    Const xlCellTypeLastCell = 11
    Const xlUp = -4162

    Dim Sy, oSh1, oSh2, sCol
    Dim Dy, n

    Set oSh1 = oBook1.Worksheets(1)
    Set oSh2 = oBook2.Worksheets(1)
   
    'очистка листа-назначения
    oSh2.Range(oSh2.Range("A3"), oSh2.UsedRange.SpecialCells(xlCellTypeLastCell)).ClearContents
   
    Dy = 2
    For Sy = 2 To oSh1.Cells(oSh1.Cells.Rows.Count, 1).End(xlUp).Row
        n = n + 1
        oSh2.Cells(Dy + n, oSh2.Columns("A").Column).Value = n                                              '№ п/п
        oSh2.Cells(Dy + n, oSh2.Columns("D").Column).Value = oSh1.Cells(Sy, oSh2.Columns("A").Column).Value 'фирма
        oSh2.Cells(Dy + n, oSh2.Columns("B").Column).Value = oSh1.Cells(Sy, oSh2.Columns("E").Column).Value '№ поставки
        Select Case LCase(Trim(oSh1.Cells(Sy, oSh2.Columns("B").Column).Value)) 'vid_tech
        Case "системный блок": sCol = "G"
        Case "ноутбук": sCol = "H"
        Case "монитор": sCol = "I"
        Case "манипулятор": sCol = "J"
        Case Else: MsgBox "Вид техники не определён: позиция " & n
        End Select
        if sCol <> "" then
            oSh2.Cells(Dy + n, oSh2.Columns(sCol).Column).Value = oSh1.Cells(Sy, oSh2.Columns("C").Column).Value 'расшифровка
        end if
    Next
End Sub

Function GetExcel()
    on error resume next
    set GetExcel = GetObject("","Excel.Application")
    if Err.Number <> 0 then
        Err.Clear
        set GetExcel = CreateObject("Excel.Application")
        if Err.Number <> 0 then
            WScript.Echo ("Не могу открыть программу Microsoft Excel!")
            WScript.Quit (1)
        end if
    end if
End Function