Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
Задать дробный формат чисел для TextBox, Доброговремени суток, форумчане. Возможно тема простая, но у меня не получается ее решить: есть TextBox1 и TextBox2ю
 
Я извеняюсь, а можете конкретно объяснить как это работает - не совсем понимаю
Задать дробный формат чисел для TextBox, Доброговремени суток, форумчане. Возможно тема простая, но у меня не получается ее решить: есть TextBox1 и TextBox2ю
 
Доброговремени суток, форумчане. Возможно тема простая, но у меня не получается ее решить: есть TextBox1, TextBox2, и TextBox3..В первом фиксированные числа, которые тянутся ВПР-ом (цены на продукцию), а во втором количество (вес). соответственно в третьем должен быть итог. Я нашел код который данные из TextBox переобразует в дробное число и позволяет проводить манипулации. Но похоже что-то не так пошло поскольку VBA выдает ошибку Type Mismach
Код
Private Sub TxtAmount_Change()
Dim n1 As Double
    n1 = CDbl(Me.txtamount) 'ошибка вознкает в этой линии
    n2 as integer
    n2 = CInt(Me.txtprice)
 If Me.txtamount.value = ""  or me.txtprice.value = "" then 
      me.txttotal.value = ""
 Else ve.txttotal.value = n1*n2
 End If
End Sub
Подскажите пожалуйста как это можно исправить.
Применить один запрос к каждой книге в папке, Power QUERY
 
Не понимаю сути проблемы, простите. Вам нужно консолидировать все файлы в папке, оставить только одну шапку, убрать ненужные столбцы и дублирующиеся строки? Я правильно понимаю? Тогда метод, который я использую то что надо очень прост в применении. Если хотите могу подробно описать шаг за шагом
Применить один запрос к каждой книге в папке, Power QUERY
 
Попробуйте следующий код вложить в тело Advanced Edıtor.  Что он будет делать: брать одинаковые файлы с идентичными шапками и, соответственно количестовом колон и соберет из них одну таблицу
Код
Let
 Source = Folder.Files("Путь к папке"),
    #"Removed Other Columns" = Table.SelectColumns(Source,{"Content"}),
    #"Added Custom" = Table.AddColumn(#"Removed Other Columns", "Input", each Excel.Workbook([Content])),
    #"Removed Columns" = Table.RemoveColumns(#"Added Custom",{"Content"}),
    #"Expanded Input" = Table.ExpandTableColumn(#"Removed Columns", "Input", {"Name", "Data", "Item", "Kind"}, {"Input.Name", "Input.Data", "Input.Item", "Input.Kind"}),
    #"Added Custom1" = Table.AddColumn(#"Expanded Input", "SkipRows", each Table.Skip([Input.Data],14)),
    #"Removed Other Columns1" = Table.SelectColumns(#"Added Custom1",{"SkipRows"}),
    #"Added Custom2" = Table.AddColumn(#"Removed Other Columns1", "PromoteHeaders", each Table.PromoteHeaders([SkipRows])),
    #"Removed Other Columns2" = Table.SelectColumns(#"Added Custom2",{"PromoteHeaders"}),
    #"Expanded PromoteHeaders" = Table.ExpandTableColumn(#"Removed Other Columns2", "PromoteHeaders", {""}
Изменено: Adilet_Yess - 11.03.2019 12:08:55
ListBox c мултивыбором перенос на лист
 
Добрый день, уважаемые форумчане. Пытаюсь скопировать данные из ЛистБокса из трех колон на лист - не получается. Подскажите пожалуйста в чем загвоздка. выбрасывает ошибку "Odject Required" Ниже прилагаю код и книгу. Нашел данный код на форумах немного изменил под себя. Это должно стать частью большого макроса связывающего несколько файлов и выполняющего проверку на совпадения с наименованиями в листбоксе

Заранее спасибо
Код
Private Sub CommandButton1_Click()
 Dim lnItem As Long
  Dim ws As Worksheet
   Set ws = Workbooks("DATATEST").Worksheets(2)
  For lnItem = 0 To ListBox.ListCount - 1
   If ListBox.Selected(lnItem) = True Then
    Dim NextRow As Long
        NextRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Offset(1, 0).Row
        If ws.Range("B4").Value = "" And ws.Range("C4").Value = "" Then
           NextRow = NextRow - 1
          End If
          ws.Cells(NextRow, 3).Value = Me.ListBox.List(lnItem, 1)
          ws.Cells(NextRow, 4).Value = Me.ListBox.List(lnItem, 2)
   End If
  Next lnItem
End Sub

Private Sub UserForm_Initialize()
 ListBox.ColumnCount = Range(ListBox.RowSource).Columns.Count
End Sub
Изменено: Adilet_Yess - 11.03.2019 11:56:21
Сравнение двух диапазонов и дополнение данных в одном диапазоне другим
 
А как поступить с динамическим списком? Ведь могут добавляться новые оборудования. Как их вносить?
Сравнение двух диапазонов и дополнение данных в одном диапазоне другим
 
Да. Но понимаете нужен именно макрос, поскольку если делать через формулу данные в столбце количества будут затираться новыми данными. А мне нужно чтобы к остаточному количеству добавлялось новое количество. Название оборудования уникальны
Сравнение двух диапазонов и дополнение данных в одном диапазоне другим
 
Прошу прощения за неточность, это столбец "B:B"  в книге BASA. В этом столбце будет указываться количество оборудования.
Сравнение двух диапазонов и дополнение данных в одном диапазоне другим
 
      Добрый день, уважаемые форумчане. Подскажите пожалуйста как сравнить и дополнить данные из одного диапазона данными из второго. Нужен макрос (конечно, можно было бы просто ручками дописать формулу, но для дальнейших действий нужен именно макрос).
    В книге Example2 диапазон с названиями оборудования динамичен. Ими нужно дополнить  данные в книге BASA. следующий столбец ("C:C") содержит количество оборудования, соответственно при каждом обновлении, в книге BASA в соответствующем столбце нужно дополнять (прибавить к имеющемуся количеству) данные.

Заранее благодарю
Разница в днях между текущей датой и первой датой в днях
 
Я новичек в VBA))). Файл-пример только собираю.
Разница в днях между текущей датой и первой датой в днях
 
  Добрый день, уважаемые форумчане Вопрос, наверное, легкий, но мне как новичку немного сложно найти правильное решение.
 Создаю Пользовательскую форму где есть поля текущей даты и даты первой сдачи в эксплуатацию и др. . Идея следующая: Есть две книги (условно назовем их "Форма" и "Таблица"). Пользовательская форма (далее ПФ) находится в книге "Форма", а записи о выдаче инструментов  ведутся в книге "Таблица". Данные в текстбоксах и комбобоксах ложаться одной строкой в книгу "Таблица". Содержимое текстбокса "Дата" (настроена та текущую дату) записывается в столбец "B2:B". И когда в следующий раз инструмент будет выдаваться повторно то в текстбоксе "Дата первой эксплуатации" должна появиться  дата первой выдачи данного инструмента, а в текстбоксе "В использовании, дней" разница в днях между текущей датой и соответственно первой датой. Все инструменты уникальны (в качестве превичного ключа используется ID).

Заранее благодарю за помощь  и понимание)))
Изменено: Adilet_Yess - 25.02.2019 09:17:06
Обход "Защищенного просмотра" и "Включить содержимое" при открытии книги "XLSM"
 
magistor8, спасибо. Сейчас буду разбираться)))
Обход "Защищенного просмотра" и "Включить содержимое" при открытии книги "XLSM"
 
Добрый день, уважаемые форумчане! Скажите пожалуйста существует ли способ обойти такие предупреждения как "Protected view"  и "Enable content" в макросодержащей книге. Я создал пользовательскую форму и написал макрос чтобы при открытии книги автоматом всплывала только форма а книга скрывалась (делается для скрытия данных от заполняющего). Но когда я открываю книгу сначала всплывают вот эти предупреждения и только после них срабатывает макрос.
Как можно решить эту проблему?
Заранее благодарю
Проблема при назначении комбобоксу функции WorksheetFunction.Index и WorksheetFunction.Match
 
Ігор Гончаренко, огромное спасибо!!!! Все заработало
Проблема при назначении комбобоксу функции WorksheetFunction.Index и WorksheetFunction.Match
 
Добрый день, уважаемые форумчане.

У меня возникла следующая проблема: В экселе создал ползовательскую форму и привязал все комбобоксы друг к другу так чтобы при выборе из выпадающего списка одного объекта все последующие заполнялись при помощи  WorksheetFunction.Index и WorksheetFunction.Match. Проблема же заключается в том, что когда идентичный макрос назначаю для комбобокса cboSapCode приложение выдает ошибку. Ниже прилагаю файлик который идентичен исходному файлу (все необходимые поля есть).
Код
Private Sub cboEquipment_Change()
 Dim ws As Worksheet
  Set ws = Workbooks("Test").Worksheets("EQUIPMENT")
   Dim rn As Range
    Set rn1 = ws.Range("EQUIPMENT")
    If Me.cboEquipment.Value = "" Then
       Me.cboProdCode.Value = ""
    Else: Me.cboProdCode.Value = WorksheetFunction.Index(ws.Range("PRODUCT_CODE"), WorksheetFunction.Match(Me.cboEquipment.Value, ws.Range("EQ_RNG"), 0))
    End If
End Sub

Private Sub cboProdCode_Change()
 Dim ws As Worksheet
  Set ws = Workbooks("Test").Worksheets("EQUIPMENT")
   Dim rn As Range
    Set rn1 = ws.Range("EQUIPMENT")
    If Me.cboProdCode.Value = "" Then
       Me.cboSapCode.Value = ""
    Else: Me.cboSapCode.Value = WorksheetFunction.Index(ws.Range("SAP_CODE"), WorksheetFunction.Match(Me.cboProdCode.Value, ws.Range("PRODUCT_CODE"), 0))
    End If
End Sub

Private Sub cboSapCode_Change()
 Dim ws As Worksheet
  Set ws = Workbooks("Test").Worksheets("EQUIPMENT")
   Dim rn As Range
    Set rn1 = ws.Range("EQUIPMENT")
    If Me.cboSapCode.Value = "" Then
       Me.cboEquipment.Value = ""
    Else: Me.cboEquipment.Value = WorksheetFunction.Index(ws.Range("EQ_RNG"), WorksheetFunction.Match(Me.cboSapCode.Value, ws.Range("SAP_CODE"), 0)) 'Строка с ошибкой
    End If
End Sub
Весь прикол в том, что все остальные абсолютно идентичные макросы работают и именно этот молчит как партизан. Помогите пожалуйста
запись данных в ячейку с помощью Application.Index и Application.Match
 
Ігор Гончаренко, метод, который Вы указали в принципе находит искомую ячейку, но не может заменить ее значения. :oops:
Во вложении файлы можете посмотреть что не так. Заранее спасибо
запись данных в ячейку с помощью Application.Index и Application.Match
 
Ігор Гончаренко, Большое спасибо буду пробовать
запись данных в ячейку с помощью Application.Index и Application.Match
 
Ігор Гончаренко, не совсем понял (прошу простить за мой французский :oops: ). Можете подробнее описать
запись данных в ячейку с помощью Application.Index и Application.Match
 
   Добрый день, уважаемые форумчане. Подскажите пожалуйста как произвести запись в ячейку в двумерном массиве найденном с помощью Application.Index и Application.Match. Нашел здесь на форуме как искать значение в двумерном массиве без VLOOKUP,  за что огромное спасибо. Но вот заменить ее значение не получается. Ниже макрос, который я использовал
Код
Sub Test ()
 Dim Wb1, Wb2, kniga as string
   wb1 = Thisworkbook.Name
    kniga = "C:\Users..."
     wb2 = Dir (kniga)
      Dim ws1, ws2 as Worksheets
       Set ws1 = Workbooks("Workbook1").Worksheets(1)
         
  With GetObject (Wb2)
   Dim Ws2 as Worksheet
    Set Ws2 = Workbooks("Workbook2").Worksheets(2)
     Dim Rng_1, Rng_2, Rng_3 as Range
      Set Rng_1 = Ws2.Range("A2:A35")
       Set Rng2 = Ws2.Range("B1:Z1")
        Set Rng_3 = Ws2.Range("B2:Z35")
     
   i = Application.Match(Ws1.Range("B2"), Ws2.Range("Rng_1"), 0)
   j = Application.Match(Ws1.Range("B3"), Ws2.Range("Rng_2"), 0)
   k = Application.Index(Ws2.Range("Rng_3"), i, j)
   
    If Ws1.Range("C2").Value = "" Then
         MsgBox ("Warning! Fill the blank field!") 
       ElsIf Ws1.Range("C2").Value > k Then
         MsgBox ("Not Enough!")
       Else: k = k - Ws1.Range("C2").Value 'Не получается перезаписать значение k 
   End With
   Workbooks("Workbook2").Close (True)
   ...
     
    Действие выполняется на первой книге. Еще нужно что бы если условие первое или второе верно то постоянно всплывал MsgBox с соответствующим сообщением, а не перекидывал на макрос. функции Application.Match и Application.Index  работают отлично, но вот перезаписать как-то не получается. Поскольку я новичек в написании макросов прошу отнестись с пониманием))). Если есть какие-нибудь недочеты в коде прошу поправить.
Метод Select класса Range в скрытой книге вызывает ошибку.
 
Nordheim, я пробовал активировать лист и выбирать саму переменную как вы и предлагаете, но все равно не получается
Метод Select класса Range в скрытой книге вызывает ошибку.
 
Добрый день. Нужна помощь  с выделением диапазона - из активной книги "Форма"  через GetObject я обращаюсь к  "DATABASE_2", где в умную таблицу  записываются данные из одноименных диапазонов из книги "Форма". В столбце "В" производится нумерация каждой записи начиная с ячейки "В4". Но после первой записи макрос начинает ругаться. Полагаю что ошибка появляется из-за того, что книга "DATABASE_2" скрыта поскольку когда я делаю ее видимой то макрос работает правильно. Но в том то и проблема что заполняющий данные в книге "Форма" не должен видеть книгу "DATABASE_2".Перепробовал несколько методов таких как активация листа и после команда Select но не помогло...
Код
Sub AddData()
Dim WbFm, WbDb As String
 WbFm = ThisWorkbook.Name
 WbDb = "C:...DATABASE.XLSX_2"
  Dim MyForm As Worksheet
   Set MyForm = Workbooks("Форма").Worksheets("FORM")
    With MyForm
     MyForm.Unprotect "1234"
    End With
       GetObject (WbDb)
       Dim Database As Worksheet
        Set Database = Workbooks("DATABASE").Worksheets("DATASHEET")
         With Database
         Dim NextRow As Long
          NextRow = Database.Cells(Database.Rows.Count, 3).End(xlUp).Offset(1, 0).Row
           If Database.Range("B4").Value = "" And Database.Range("C4").Value = "" Then
            NextRow = NextRow - 1
           End If
            MyForm.Range("DATE").Copy
        Database.Cells(NextRow, 3).PasteSpecial Paste:=xlPasteValues
        Database.Cells(NextRow, 4).Value = MyForm.Range("REGION").Value 'Именованный диапазон в книге Форма на Листе FORM
        Database.Cells(NextRow, 5).Value = MyForm.Range("RESPONSIBLE").Value
        Database.Cells(NextRow, 6).Value = MyForm.Range("RESPONSIBLE_NAME").Value
        Database.Cells(NextRow, 7).Value = MyForm.Range("DIVISION").Value
        Database.Cells(NextRow, 8).Value = MyForm.Range("DIVISION_NAME").Value
        Database.Cells(NextRow, 9).Value = MyForm.Range("FROM").Value
        Database.Cells(NextRow, 10).Value = MyForm.Range("FROM_NAME").Value 'Именованный диапазон в книге Форма на Листе FORM
        
        Database.Range("B4").Formula = "=If(ISBLANK(C4), """", COUNTA($C$4:C4))" 'Для нумерации каждой строки
  
        If NextRow > 4 Then
        Database.Activate
            Database.Range("B4").Select 'Строка с ошибкой
        Selection.AutoFill Destination:=Range("B4:B" & NextRow)
        Range("B4:B" & NextRow).Select
        End If
       End With
    End Sub
Перезапись данных в ячейку, найденную с помощью Application.Index
 
Добрый день, форумчане. Продолжаю тонкости языка VBA ... Скажите как можно перезаписать данные в ячейке которую я нашел с помощью Application.Index?  Ниже прилагаю отрезок от кода VBA
Все работает замечательно (кстати P\Applicaion.Index  тоже нашел здесь на форуме, за что большое спасибо). Но записать никак не удается. Помогите новичку. Прошу понять, простить :D
Код
Sub AddData()
Dim WbFm, WbSpr, WbDb As String
 WbFm = ThisWorkbook.Name
 WbSpr = "..."
 WbDb = "..."
  Dim MyForm As Worksheet
   Set MyForm = Workbooks("Form_Last").Worksheets("ФОРМА")
    With MyForm
     MyForm.Unprotect "1234"
    End With
    GetObject (WbSpr)
     Dim Datasheet As Worksheet
     Set Datasheet = Workbooks("Directory").Worksheets("TABLE")
      Dim Eq, Obj, Tbl As Range
       Set Obj = Datasheet.Range("C1:KJF1")
       Set Eq = Datasheet.Range("B2:B269")
       Set Tbl = Datasheet.Range("E2:KJF269")
        h = Application.Match(MyForm.Range("TO_NAME"), Datasheet.Range("Obj"), 0)
        i = Application.Match(MyForm.Range("EQUIPMENT"), Datasheet.Range("Eq"), 0)
        j = Application.Match(MyForm.Range("FROM_NAME"), Datasheet.Range("Obj"), 0)
        k = Application.Index(Datasheet.Range("Tbl"), i, j)
         If MyForm.Range("AMOUNT").Value = "" Then
         MsgBox ("Внимание! Заполните пустое поле!")
          ElseIf MyForm.Range("AMOUNT").Value > k Then
          MsgBox ("Недостаточное количество оборудования")
           Else: k = k - MyForm.Range("AMOUNT").Value
                 h = k
           End If
     Workbooks("Directory").Saved = True
     Workbooks("Directory").Close (True)
Изменено: Adilet_Yess - 15.01.2019 12:38:38
Защита ячеек на незащищенном листе
 
Нет, в принципе все верно. Но есть ячейки,  которых люди не должны касаться вовсе даже после снятия защиты. А поскольку "Умных" людей много, то нужна "Защита от дураков"  
Защита ячеек на незащищенном листе
 
Добрый день уважаемы форумчане. Подскажите пожалуйста как защитить ячейки от ввода данных на незащищенном листе и скрыть формулы. Дело в том что я макросом снимаю защиту с листа и тем самым формулы становятся видимыми  и защита тоже слетает.
В идеале же нужно чтобы после снятия защиты поля, которые заполняются автоматом по условию, оставались защищенными, а формулы невидимыми.

Заранее спасибо
Как с помощью VBA взять данные из таблицы на пересечении указанных названий строки и столбца?
 
Код
Sub test_1()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws, ws2 As Worksheet
Set ws = wb.Worksheets("TABLE")
Set ws2 = wb.Worksheets("FORM")
Dim Station, Equipment, Amount As Range
Set Station = ws2.Cells(4, 3)
Set Equipment = ws2.Cells(5, 3)
Set Amount = ws2.Cells(6, 3)
i = Application.Match(ws2.Range("EQUIPMENT").Value, ws.Range("EQ"), 0) 
j = Application.Match(ws2.Range("Object").Value, Range("OBJ"), 0)
k = Application.INdex(Range("TBL"), i, j) 
End Sub
Прошу простить за корявость кода - я только только начал изучать VBA b многих тонкостей не знаю )))   и еще один момент диапазоны OBJ и EQ я задал не с помощью макроса а так, переименовали выделив нужные ячейки.
Допустил грубейшую ошибку за что прошу простить
Код
k = Application.INdex(Range("TBL"), i, j) 
Изменено: Adilet_Yess - 08.01.2019 13:32:36
Как с помощью VBA взять данные из таблицы на пересечении указанных названий строки и столбца?
 
Так ведь ячейка не статична она будет меняться исходя из того что выбрано на листе FORM
Как с помощью VBA взять данные из таблицы на пересечении указанных названий строки и столбца?
 
Добрый день, знатоки VBA. У меня появилась следующая проблема при написании макроса для поиска ячейки на пересечении столбца и строки. Нашел подходящие функции здесь же на форуме (за что огромное спасибо). Но вот в чем загвоздка у меня таблица (точнее количество столбцов) огромная и я попытался объявить шапку столбцов диапазоном и в нем выискивать нужное значение, аналогично и со строками. Но макрос выдает ошибку OUT OF RANGE. Прошу помочь с данной задачей.
Код
Sub test_1()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws, ws2 As Worksheet
Set ws = wb.Worksheets("TABLE")
Set ws2 = wb.Worksheets("FORM")
Dim Object, Equipment, Amount As Range
Set Object = ws2.Cells(4, 3)
Set Equipment = ws2.Cells(5, 3)
Set Amount = ws2.Cells(6, 3)
i = Application.Match(ws2.Range("Equipment").Value, Range("TBL").Value, 0) 'Не правильно объявляю переменную перепробовал несколько методов - не получается
j = Application.Match(ws2.Range("Object").Value, Range("TBL").Value, 0)
k = Application.Match(Range("TBL"), i, j) 'типа двумерный поиск по названию оборудования (строки) и объекта (столбцы), работает если брать адрес ячейки а вот на диапазонах тупит
End Sub
Немного о макросе: он должен найти значение ячейки на пересечении строки и столбца (объект и оборудование, которые выбираются  из выпадающего списка на листе FORM)  и сравнить это самое значение с тем что вписано в поле AMOUNT на листе FORM. Если заданное число в поле AMOUNT меньше или равно значению ячейки то позволить дальнейшее действие если нет то MsgBOX.
Сравнение значения ячейки в одной книге со значением ячейки в другой по нескольким критериям VBA
 
Добрый день, уважаемые форумчане. У меня возникла следующая проблема:
  Есть две книги:
  1 - это форма для заполнения по перемещению оборудования из одного объекта на другой. Там есть поля "Откуда", "Оборудование"  и "Количество". А так же есть определенный макрос, который записывает все заполненные поля в другую таблицу в третьей книге.
  2 - это собственно учет остатков материала на определенном объекте. В ней таблица где наименование оборудования лежит в строках и имена объектов в столбцах, а на пересечении соответственно остаток. Задача следующая:  
Нужен макрос (точнее дописать имеющийся), который бы сравнил остатки определенного оборудования в книге 2  и внесенное сотрудником количество в книге 1 и если внесенное количество меньше чем остаток то продолжил операцию параллельно вычитая внесенное количество от остатка. если же внесенное количество больше чем остаток в книге 2 то выдавал сообщение с ошибкой типа "задано неверное количество".
   Я так полагаю что чтобы вычесть от остатка внесенное количество макрос сначала должен сравнить имена оборудования и объекта
Код
Sub AddDATA()
    Dim KNIGA As String
    Dim ITK, IOK As String
    KNIGA = "C:\Users\adilet.yessaliyev\Desktop\DATABASE.XLSX"
    ITK = ThisWorkbook.Name
    IOK = Dir(KNIGA)
    GetObject (KNIGA)
    Dim WSDATA As Worksheet
    Set WSDATA = Workbooks(IOK).Worksheets("DATASHEET")
    Dim nextRow As Long
    nextRow = WSDATA.Cells(WSDATA.Rows.Count, 3).End(xlUp).Offset(1, 0).Row
    
    Dim rConstants As Range
    With Workbooks(ITK).Worksheets("FORM")
        Worksheets("FORM").Unprotect "1234"
    End With
    
    With Workbooks(IOK).Worksheets("DATASHEET")
    
        If .Range("b4").Value = "" And .Range("C4").Value = "" Then
            nextRow = nextRow - 1
        End If
        
        Workbooks(ITK).Worksheets("FORM").Range("DATE").Copy
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 3).PasteSpecial Paste:=xlPasteValues
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 4).Value = Workbooks(ITK).Worksheets("FORM").Range("REGION").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 5).Value = Workbooks(ITK).Worksheets("FORM").Range("RESPONSIBLE").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 6).Value = Workbooks(ITK).Worksheets("FORM").Range("RESPONSIBLE_NAME").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 7).Value = Workbooks(ITK).Worksheets("FORM").Range("DIVISION").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 8).Value = Workbooks(ITK).Worksheets("FORM").Range("DIVISION_NAME").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 9).Value = Workbooks(ITK).Worksheets("FORM").Range("FROM").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 10).Value = Workbooks(ITK).Worksheets("FORM").Range("FROM_NAME").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 11).Value = Workbooks(ITK).Worksheets("FORM").Range("TO").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 12).Value = Workbooks(ITK).Worksheets("FORM").Range("TO_NAME").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 13).Value = Workbooks(ITK).Worksheets("FORM").Range("EQUIPMENT").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 14).Value = Workbooks(ITK).Worksheets("FORM").Range("CODE_TYPE").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 15).Value = Workbooks(ITK).Worksheets("FORM").Range("CODE").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 16).Value = Workbooks(ITK).Worksheets("FORM").Range("AMOUNT").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 17).Value = Workbooks(ITK).Worksheets("FORM").Range("RECIEVER").Value
        Workbooks(IOK).Worksheets("DATASHEET").Cells(nextRow, 18).Value = Workbooks(ITK).Worksheets("FORM").Range("RECIEVER_NAME").Value
               
        Workbooks(IOK).Worksheets("DATASHEET").Range("B4").Formula = "=If(ISBLANK(C4), """", COUNTA($C$4:C4))"
        
        If nextRow > 4 Then
            Workbooks(IOK).Worksheets("DATASHEET").Activate
            Workbooks(IOK).Worksheets("DATASHEET").Range("B4").Select
            Selection.AutoFill Destination:=Range("B4:B" & nextRow)
            Range("B4:B" & nextRow).Select
        End If
        Workbooks(ITK).Worksheets("FORM").Activate
         
         Set rConstants = Workbooks(ITK).Worksheets("FORM").Range("ENTRIES").SpecialCells(xlCellTypeConstants)
         rConstants.ClearContents
    End With
    Workbooks(IOK).Close (True)
    With Workbooks(ITK).Worksheets("FORM")
        Worksheets("FORM").Protect "1234"
    End With
End Sub
Заранее благодарю
Изменено: Adilet_Yess - 13.12.2018 08:11:09
Данные из диапазона в активной книге вставить как таблицу в другую книгу
 
Вот собственно и таблица. Правда заранее убрано все конфидециальное
Данные из диапазона в активной книге вставить как таблицу в другую книгу
 
Добрый день, знатоки VBA. Мне нужна ваша помощь по написанию корректного макроса. Цель следующая: из активной книги в листе MyForm взять заполненные данные из диапазона вставить в другую книгу но уже как таблицу, затем сохранить и стереть данные из формы для заполнения(в некоторых ячейках есть формулы их нужно оставить). Ниже прилагаю макрос который я подсмотрел в видеоуроке и немного подшаманил. Я новичек в написании макросов так что прошу отнестись с пониманием)))
Заранее спасибо
P.S.  в скрипте, возможно, много ненужных вещей. Поэтому прошу помочь с оформлением. прилагаю саму книгу с формой для заполнения а на листе TAble таблица в которую должны вписываться данные но в другой книге
Код
Sub AddDATA()
    Dim KNIGA As String
    Dim ITK, IOK As String
    KNIGA = "C:\Users\adilet.yessaliyev\Desktop\DATABASE.XLSX"
    ITK = ThisWorkbook.Name
    IOK = Dir(KNIGA)
    GetObject (KNIGA)
    Dim WSDATA As Worksheet
    Set WSDATA = Workbooks(IOK).Worksheets(DATASHEET)
    Dim nextRow As Long
    nextRow = Workbooks(IOK).Worksheets(DATASHEET).Cells(WSDATA.Rows.Count, 3).End(xlUp).Offset(1, 0).Row
    
    Dim rConstants As Range
    
    With Workbooks(ITK).Worksheets(MyDataList)
    
        If .Range("b4").Value = "" And .Range("C4").Value = "" Then
            nextRow = nextRow - 1
        End If
        
        Workbooks(IOK).Worksheets(MyForm).Range("DATE").Copy
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 3).PasteSpecial Paste:=xlPasteValues
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 4).Value = Workbooks(ITK).Worksheets(MyForm).Range("REGION").Value
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 5).Value = Workbooks(IOK).Worksheets(MyForm).Range("RESPONSIBLE").Value
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 6).Value = Workbooks(IOK).Worksheets(MyForm).Range("RESPONSIBLE_NAME").Value
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 7).Value = Workbooks(IOK).Worksheets(MyForm).Range("RESPONSIBLE_DIVISION").Value
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 8).Value = Workbooks(IOK).Worksheets(MyForm).Range("DIVISION_NAME").Value
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 9).Value = Workbooks(IOK).Worksheets(MyForm).Range("FROM").Value
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 10).Value = Workbooks(IOK).Worksheets(MyForm).Range("FROM_NAME").Value
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 11).Value = Workbooks(IOK).Worksheets(MyForm).Range("TO").Value
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 12).Value = Workbooks(IOK).Worksheets(MyForm).Range("TO_NAME").Value
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 13).Value = Workbooks(IOK).Worksheets(MyForm).Range("CODE_TYPE").Value
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 14).Value = Workbooks(IOK).Worksheets(MyForm).Range("CODE").Value
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 15).Value = Workbooks(IOK).Worksheets(MyForm).Range("PRODUCT_NAME").Value
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 16).Value = Workbooks(IOK).Worksheets(MyForm).Range("RECIEVER").Value
        Workbooks(ITK).Worksheets(MyDataList).Cells(nextRow, 17).Value = Workbooks(IOK).Worksheets(MyForm).Range("RECIEVER_NAME").Value
               
        Workbooks(ITK).Worksheets(MyDataList).Range("B4").Formula = "=If(ISBLANK(C4), """", COUNTA($C$4:C4))"
        
        If nextRow > 4 Then
            Workbooks(ITK).Worksheets(MyDataList).Activate
            Workbooks(ITK).Worksheets(MyDataList).Range("B4").Select
            Selection.AutoFill Destination:=Range("B4:B" & nextRow)
            Range("B4:B" & nextRow).Select
        End If
        Workbooks(IOK).Worksheets(MyForm).Activate
         
         Set rConstants = Workbooks(IOK).Worksheets(MyForm).Range("ENTRIES").SpecialCells(xlCellTypeConstants)
         rConstants.ClearContents
         ActiveWindow.DisplayFormulas = False
    End With
    Workbooks(IOK).Close (True)
End Sub
Изменено: Adilet_Yess - 04.12.2018 13:39:00
Страницы: 1
Наверх