Помогите написать VBA код для инсерта в таблицу (Excel 2010) - Страница 2

Дата: Воскресенье, 09.09.2012, 01:24 | Сообщение № 21

Группа: Гости

Не получился у меня
потому что при копирование название таблиц меняется по этому не смог

Serge_007

Дата: Воскресенье, 09.09.2012, 01:31 | Сообщение № 22

Группа: Админы

Ранг: Местный житель

Сообщений: 16475

Репутация: 2749 ±

Замечаний: ±

Excel 2016

Quote (Гость)

при копирование название таблиц меняется по этому не смог

При чём здесь названия таблиц?
Что не смог?
Что надо получить?

ЮMoney:41001419691823 | WMR:126292472390

Дата: Воскресенье, 09.09.2012, 01:33 | Сообщение № 23

Группа: Гости

Перед использованием
[vba]

Код

Sub CopyKino()
Dim n&
Dim Msg, Style, Title, Response
Msg = "Макрос справился с задачей?"
Style = 4
Application.DisplayAlerts = False
Sheets("Лист1").Copy Before:=Sheets(1)

n = [journal].Columns(5).End(xlDown).Row
If n = Rows.Count Then n = [journal].Columns(5).End(xlUp).Row
Application.ScreenUpdating = False
[kino].Columns(1).Copy Cells(n + 1, [journal].Columns(5).Column)
[kino].Columns(2).Copy Cells(n + 1, [journal].Columns(6).Column)
Application.ScreenUpdating = True
Sheets("Лист1 (2)").Visible = False
Response = MsgBox(Msg, Style)
If Response = vbYes Then
Sheets("Лист1 (2)").Delete
Else
Sheets("Лист1 (2)").Visible = True
Sheets("Лист1").Delete
Sheets("Лист1 (2)").Name = "Лист1"
End If
Application.DisplayAlerts = True
End Sub

[/vba]

не работает там при копирование на новый лист название таблиц автоматом номер добавляется уменя в коде название таблиц жестка прописано

Serge_007

Дата: Воскресенье, 09.09.2012, 01:37 | Сообщение № 24

Группа: Админы

Ранг: Местный житель

Сообщений: 16475

Репутация: 2749 ±

Замечаний: ±

Excel 2016

Quote (Serge_007)

При чём здесь названия таблиц?

?!

Листы в файле как называются?

ЮMoney:41001419691823 | WMR:126292472390

Дата: Воскресенье, 09.09.2012, 01:41 | Сообщение № 25

Группа: Гости

Лист1
Лист2

Дата: Воскресенье, 09.09.2012, 01:41 | Сообщение № 26

Группа: Гости

Файл
http://rghost.ru/40260761

Дата: Воскресенье, 09.09.2012, 01:49 | Сообщение № 27

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

Если вообще ничего не известно:
[vba]

Code

Sub CopyKino()
     Dim cc As Object, from_ As Range, to_ As Range
     For Each cc In ActiveSheet.ListObjects
         If cc.HeaderRowRange(1, 1) = "Кинотеатр" Then Set from_ = cc.DataBodyRange
         If cc.HeaderRowRange(1, 1) = "№" Then Set to_ = cc.DataBodyRange
     Next
     Set to_ = to_.Offset(to_.Rows.Count)
     Application.ScreenUpdating = False
     from_.Columns(1).Copy to_.Columns(5)
     from_.Columns(2).Copy to_.Columns(6)
     Application.ScreenUpdating = True
End Sub

Sub CopySale()
     Dim cc As Object, from_ As Range, to_ As Range
     For Each cc In ActiveSheet.ListObjects
         If cc.HeaderRowRange(1, 1) = "Торговля" Then Set from_ = cc.DataBodyRange
         If cc.HeaderRowRange(1, 1) = "№" Then Set to_ = cc.DataBodyRange
     Next
     Set to_ = to_.Offset(to_.Rows.Count)
     Application.ScreenUpdating = False
     from_.Columns(1).Copy to_.Columns(5)
     from_.Columns(2).Copy to_.Columns(6)
     Application.ScreenUpdating = True
End Sub

[/vba]
Но есть одно НО (лень бороться) - что-то уже в нижней таблице должно быть записано!

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Дата: Воскресенье, 09.09.2012, 09:20 | Сообщение № 28

Группа: Гости

HUGO
Не получился все равно ругает

Дата: Воскресенье, 09.09.2012, 11:43 | Сообщение № 29

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

Кто кого ругает?
Вы сперва заполнили первую строку сводной таблицы? А то сейчас я ругать буду smile

И когда копируете на форум код - следите за раскладкой, и оформляйте тегами. А то позорище я под спойлер спрятал smile

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Дата: Воскресенье, 09.09.2012, 14:08 | Сообщение № 30

Группа: Гости

Ок спасибо
Да первый решился но я не знал что после макроса нельзя отменит
просто из за прокси отключено функции
Как вы решаете отмену после макроса?
Просто то что дал Serge_007 я не могу применить..

[vba]

Code

Sub CopyKino2()
       Dim cc As Object, from_ As Range, to_ As Range
       Dim Msg, Style, Title, Response
       Msg = "Макрос справился с задачей?"
       Style = 4
       Application.DisplayAlerts = False
       Sheets("Лист1").Copy Before:=Sheets(1)
       For Each cc In ActiveSheet.ListObjects
           If cc.HeaderRowRange(1, 1) = "Кинотеатр" Then Set from_ = cc.DataBodyRange
           If cc.HeaderRowRange(1, 1) = "№" Then Set to_ = cc.DataBodyRange
       Next
       Set to_ = to_.Offset(to_.Rows.Count)
       Application.ScreenUpdating = False
       from_.Columns(1).Copy to_.Columns(5)
       from_.Columns(2).Copy to_.Columns(6)
       Application.ScreenUpdating = True
       Sheets("Лист1 (2)").Visible = False
      Response = MsgBox(Msg, Style)
      If Response = vbYes Then
      Sheets("Лист1 (2)").Delete
Else
Sheets("Лист1 (2)").Visible = True
     Sheets("Лист1").Delete
      Sheets("Лист1 (2)").Name = "Лист1"
End If
Application.DisplayAlerts = True
End Sub

[/vba]

Дата: Воскресенье, 09.09.2012, 15:22 | Сообщение № 31

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

Я пишу макрос так, чтоб отмену делать не пришлось.
Ну а если заметил, что ошибка (в работе такого не было) - закрываю файл без сохранения, открываю заново. Ну тут уже упоминали такой вариант.

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Дата: Воскресенье, 09.09.2012, 22:10 | Сообщение № 32

Группа: Гости

HUGO подскажите как правильно встаить значание из ячейки суммы и даты

Code

Sub CopyKino()
    Dim n&
     ActiveSheet.ListObjects("Journal").ShowTotals = False
     n = [Journal].Columns(5).End(xlDown).Row
     If n = Rows.Count Then n = [Journal].Columns(5).End(xlUp).Row
     Application.ScreenUpdating = False
     [Kino].Columns(1).Copy Cells(n + 1, [Journal].Columns(5).Column)
     [Kino].Columns(2).Copy Cells(n + 1, [Journal].Columns(7).Column)
     [Journal].Columns(2).Value = Cells(6, 2).Value
     [Journal].Columns(3).Value = "Поступление"
     [Journal].Columns(4).Value = "Кинотеатр"
     [Journal].Columns(6).Value = Cells(7, 2).Value
     ActiveSheet.ListObjects("Journal").ShowTotals = True
     Application.ScreenUpdating = True
End Sub

Этот код при добавление заменяет старые значение

Дата: Воскресенье, 09.09.2012, 23:38 | Сообщение № 33

Группа: Гости

То есть заменять страрые значание на новый который изменил в ячейке суммы и даты

Дата: Понедельник, 10.09.2012, 00:42 | Сообщение № 34

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

Сперва Вам нужно было дописывать в конец, теперь заменять уже написанное...
Это будут совсем разные коды и алгоритмы. И заменять значительно сложнее.
Если я Вас правильно конечно понял.
Может быть нужно не заменять, а всё стереть и подтянуть заново?

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Дата: Понедельник, 10.09.2012, 07:43 | Сообщение № 35

Группа: Гости

Не очень понял
Наверно не правильно объяснил
Например
Так получается
Когда нажал на кинотеатр и указал сумму 1000 и дату 01,01,2012
эти значение вставляется в колонке общая сумма и дата

Когда нажал на торговля и указал сумму 2000 и дату 02,01,2012
эти значение вставляется в колонке общая сумма и дата

То последний сумма и дата который я ввел
на всю колонку вставляет поверх то есть заменяет

Вашем коде не получится ?
Можете помочь?

mrUlugbek

Дата: Понедельник, 10.09.2012, 13:30 | Сообщение № 36

Группа: Гости

Ура получилось
Уважаемые эксперты насколько правильно такой подход ?
Но пока работает
[CODE]
Sub testKino()
Dim table As ListObject
Dim index As Long
Dim rows As Long
Dim oNewRow As ListRow
Set table = Workbooks("FinansV2.xlsm").Worksheets("Настройки").ListObjects("Kino")
Application.ScreenUpdating = False
rows = table.ListRows.Count
For index = 1 To rows
Set oNewRow = ActiveSheet.ListObjects("Journal").ListRows.Add(AlwaysInsert:=True)
oNewRow.Range.Columns(2).value = Cells(6, 2).value
oNewRow.Range.Columns(6).value = Cells(7, 2).value
oNewRow.Range.Columns(5).value = table.Range.Cells(index + 1, 1).value
Next index
Application.ScreenUpdating = True
End Sub

/[CODE]