вставка не всех столбцов в новую книгу - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/вставка не всех столбцов в новую книгу - Мир MS Excel

Старая форма входа

Страница 1 из 2 1 2 »
Модератор форума: китин, _Boroda_

вставка не всех столбцов в новую книгу (Макросы/Sub)

вставка не всех столбцов в новую книгу

Дата: Среда, 25.08.2021, 11:15 | Сообщение № 1

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

день добрый.
есть рабочий макрос - разбивает таблицу на балансы (по столбцу -Балансы) и сохраняет новыми книгами
делал не сам (по заказу), все устраивает но хочется подправить -
1. в новые файлы чтоб вставлялись не все столбцы а до столбца - AJ (остальные столбцы вспомогательные и не нужны в тех файлах)
2. в новых файлах над шапкой таблицы что бы вставлялись не все данные, только из диапазона A7:D11

макрос запускается кнопкой -Разбить
первый файл в котором макрос второй то что получается

К сообщению приложен файл: 3263899.xlsb (69.8 Kb) · __..xlsx (15.8 Kb)

Ответить

Дата: Среда, 25.08.2021, 21:35 | Сообщение № 2

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

странно.. когда тему создавал макрос работал.....ща выдает ошибку 400....в чем может быть проблема?

Ответить

Дата: Четверг, 02.09.2021, 20:34 | Сообщение № 3

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

Знатоки посмотрите пожалуйста,
не пойму почему макрос не пашет...и как подправить свои хотелки..
то ошибка 400 то при выполнении останавливается на строке
[vba]

Код

ThisWorkbook.Worksheets("ФБ").Copy before:=newrqstbk.Worksheets(1)

[/vba]
в коде

[vba]

Код

Sub РазбитьнаБалансы()
If expired Then Exit Sub
SUBP = Application.ScreenUpdating
CABP = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Val(Application.Version) >= 12 Then
appfileformat = ".xlsx"
Else
appfileformat = ".xls"
End If
Set newrqstbk = onewsbk
ThisWorkbook.Worksheets("ФБ").Copy before:=newrqstbk.Worksheets(1)
ActiveWorkbook.Worksheets("ФБ").AutoFilter.ShowAllData
ActiveWorkbook.Worksheets("ФБ").ListObjects("Баланс1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ФБ").ListObjects("Баланс1").Sort.SortFields.Add key _
:=Range("Баланс[Баланс]"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("ФБ").ListObjects("Баланс1").Sort.SortFields.Add key _
:=Range("Баланс[Дата платежа]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("ФБ").ListObjects("Баланс1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("ФБ").UsedRange.Copy
ActiveWorkbook.Worksheets("ФБ").UsedRange.Select
Selection.PasteSpecial Paste:=xlPasteValues
driver_col = "T"
savepath = ThisWorkbook.Path + "\" + "Балансы\"
If Not ExistDir(savepath) Then MkDir (savepath)
Dim namearr()
Dim fnamearr()
li = 12
ti = 13
splitcol = driver_col
Set newrqst = newrqstbk.Worksheets(1)
lr = newrqst.UsedRange.Row + newrqst.UsedRange.Rows.Count
For i = 13 To lr
If i = lr Or newrqst.Cells(i, splitcol) <> newrqst.Cells(i + 1, splitcol) Then
Set tempbk = onewsbk
newrqst.Rows("7:12").Copy
tempbk.Activate
tempbk.Worksheets(1).Activate
tempbk.Worksheets(1).Rows(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
Selection.PasteSpecial Paste:=xlPasteColumnWidths
Range("D2:D5").FormulaR1C1 = "=SUMPRODUCT(SUBTOTAL(3,OFFSET(R7C4,ROW(INDIRECT(""1:""&ROWS(R7C4:R" + CStr(lr) + "C4)))-1,))*R7C4:R" + CStr(lr) + "C4*(R7C34:R" + CStr(lr) + "C34=RC3))"
Range("A5").FormulaR1C1 = "=COUNT(R7C1:R1048576C1)"
Rows(6).Select
Selection.AutoFilter
newrqst.Rows(CStr(li + 1) + ":" + CStr(i)).Copy
tempbk.Worksheets(1).Cells(7, 1).Select
ActiveSheet.Paste
tname = Mysaveas2(tempbk, savepath, "Баланс " + CStr(newrqst.Cells(i, splitcol)), appfileformat, getpass(newrqst.Cells(i, splitcol)))
Workbooks(tname).Close True
li = i
End If
Next i
Application.ScreenUpdating = SUBP
Application.Calculation = CABP
Call MsgBox("end")
End Sub

[/vba]
сам не разберусь, знания поверхностные, все методом научного тыка)

Знатоки посмотрите пожалуйста,
не пойму почему макрос не пашет...и как подправить свои хотелки..
то ошибка 400 то при выполнении останавливается на строке
[vba]

Код

ThisWorkbook.Worksheets("ФБ").Copy before:=newrqstbk.Worksheets(1)

[/vba]
в коде

[vba]

Код

Sub РазбитьнаБалансы()
If expired Then Exit Sub
SUBP = Application.ScreenUpdating
CABP = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Val(Application.Version) >= 12 Then
appfileformat = ".xlsx"
Else
appfileformat = ".xls"
End If
Set newrqstbk = onewsbk
ThisWorkbook.Worksheets("ФБ").Copy before:=newrqstbk.Worksheets(1)
ActiveWorkbook.Worksheets("ФБ").AutoFilter.ShowAllData
ActiveWorkbook.Worksheets("ФБ").ListObjects("Баланс1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ФБ").ListObjects("Баланс1").Sort.SortFields.Add key _
:=Range("Баланс[Баланс]"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("ФБ").ListObjects("Баланс1").Sort.SortFields.Add key _
:=Range("Баланс[Дата платежа]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("ФБ").ListObjects("Баланс1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("ФБ").UsedRange.Copy
ActiveWorkbook.Worksheets("ФБ").UsedRange.Select
Selection.PasteSpecial Paste:=xlPasteValues
driver_col = "T"
savepath = ThisWorkbook.Path + "\" + "Балансы\"
If Not ExistDir(savepath) Then MkDir (savepath)
Dim namearr()
Dim fnamearr()
li = 12
ti = 13
splitcol = driver_col
Set newrqst = newrqstbk.Worksheets(1)
lr = newrqst.UsedRange.Row + newrqst.UsedRange.Rows.Count
For i = 13 To lr
If i = lr Or newrqst.Cells(i, splitcol) <> newrqst.Cells(i + 1, splitcol) Then
Set tempbk = onewsbk
newrqst.Rows("7:12").Copy
tempbk.Activate
tempbk.Worksheets(1).Activate
tempbk.Worksheets(1).Rows(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
Selection.PasteSpecial Paste:=xlPasteColumnWidths
Range("D2:D5").FormulaR1C1 = "=SUMPRODUCT(SUBTOTAL(3,OFFSET(R7C4,ROW(INDIRECT(""1:""&ROWS(R7C4:R" + CStr(lr) + "C4)))-1,))*R7C4:R" + CStr(lr) + "C4*(R7C34:R" + CStr(lr) + "C34=RC3))"
Range("A5").FormulaR1C1 = "=COUNT(R7C1:R1048576C1)"
Rows(6).Select
Selection.AutoFilter
newrqst.Rows(CStr(li + 1) + ":" + CStr(i)).Copy
tempbk.Worksheets(1).Cells(7, 1).Select
ActiveSheet.Paste
tname = Mysaveas2(tempbk, savepath, "Баланс " + CStr(newrqst.Cells(i, splitcol)), appfileformat, getpass(newrqst.Cells(i, splitcol)))
Workbooks(tname).Close True
li = i
End If
Next i
Application.ScreenUpdating = SUBP
Application.Calculation = CABP
Call MsgBox("end")
End Sub

[/vba]
сам не разберусь, знания поверхностные, все методом научного тыка)micholap_denis

Сообщение отредактировал micholap_denis - Четверг, 02.09.2021, 20:35

Ответить

СообщениеЗнатоки посмотрите пожалуйста,
не пойму почему макрос не пашет...и как подправить свои хотелки..
то ошибка 400 то при выполнении останавливается на строке
[vba]

Код

ThisWorkbook.Worksheets("ФБ").Copy before:=newrqstbk.Worksheets(1)

[/vba]
в коде

[vba]

Код

Sub РазбитьнаБалансы()
If expired Then Exit Sub
SUBP = Application.ScreenUpdating
CABP = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Val(Application.Version) >= 12 Then
appfileformat = ".xlsx"
Else
appfileformat = ".xls"
End If
Set newrqstbk = onewsbk
ThisWorkbook.Worksheets("ФБ").Copy before:=newrqstbk.Worksheets(1)
ActiveWorkbook.Worksheets("ФБ").AutoFilter.ShowAllData
ActiveWorkbook.Worksheets("ФБ").ListObjects("Баланс1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ФБ").ListObjects("Баланс1").Sort.SortFields.Add key _
:=Range("Баланс[Баланс]"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("ФБ").ListObjects("Баланс1").Sort.SortFields.Add key _
:=Range("Баланс[Дата платежа]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("ФБ").ListObjects("Баланс1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("ФБ").UsedRange.Copy
ActiveWorkbook.Worksheets("ФБ").UsedRange.Select
Selection.PasteSpecial Paste:=xlPasteValues
driver_col = "T"
savepath = ThisWorkbook.Path + "\" + "Балансы\"
If Not ExistDir(savepath) Then MkDir (savepath)
Dim namearr()
Dim fnamearr()
li = 12
ti = 13
splitcol = driver_col
Set newrqst = newrqstbk.Worksheets(1)
lr = newrqst.UsedRange.Row + newrqst.UsedRange.Rows.Count
For i = 13 To lr
If i = lr Or newrqst.Cells(i, splitcol) <> newrqst.Cells(i + 1, splitcol) Then
Set tempbk = onewsbk
newrqst.Rows("7:12").Copy
tempbk.Activate
tempbk.Worksheets(1).Activate
tempbk.Worksheets(1).Rows(1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
Selection.PasteSpecial Paste:=xlPasteColumnWidths
Range("D2:D5").FormulaR1C1 = "=SUMPRODUCT(SUBTOTAL(3,OFFSET(R7C4,ROW(INDIRECT(""1:""&ROWS(R7C4:R" + CStr(lr) + "C4)))-1,))*R7C4:R" + CStr(lr) + "C4*(R7C34:R" + CStr(lr) + "C34=RC3))"
Range("A5").FormulaR1C1 = "=COUNT(R7C1:R1048576C1)"
Rows(6).Select
Selection.AutoFilter
newrqst.Rows(CStr(li + 1) + ":" + CStr(i)).Copy
tempbk.Worksheets(1).Cells(7, 1).Select
ActiveSheet.Paste
tname = Mysaveas2(tempbk, savepath, "Баланс " + CStr(newrqst.Cells(i, splitcol)), appfileformat, getpass(newrqst.Cells(i, splitcol)))
Workbooks(tname).Close True
li = i
End If
Next i
Application.ScreenUpdating = SUBP
Application.Calculation = CABP
Call MsgBox("end")
End Sub

[/vba]
сам не разберусь, знания поверхностные, все методом научного тыка)

Автор - micholap_denis
Дата добавления - 02.09.2021 в 20:34

Дата: Пятница, 03.09.2021, 21:48 | Сообщение № 4

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

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

Сообщений: 19404

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

Замечаний: ±

Excel 365 & Mac Excel

В приложенном файле даже вручную не удаётся скопировать этот лист в новую книгу.
Возможно, что-то сломалось)
Попробуйте перенести данные в другую книгу

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Дата: Суббота, 04.09.2021, 11:04 | Сообщение № 5

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

[

Сообщение отредактировал micholap_denis - Суббота, 04.09.2021, 11:19

Ответить

Дата: Суббота, 04.09.2021, 11:10 | Сообщение № 6

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

сделаю пример и прикреплю

Сообщение отредактировал micholap_denis - Суббота, 04.09.2021, 11:27

Ответить

Дата: Суббота, 04.09.2021, 11:57 | Сообщение № 7

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

Pelena, посмотрите пожалуйста
как подправить макрос с моими хотелками...
1. в новые файлы чтоб вставлялись не все столбцы а до столбца - AJ (остальные столбцы вспомогательные и не нужны в тех файлах)
2. в новых файлах над шапкой таблицы что бы вставлялись не все данные, только из диапазона A7:D11

К сообщению приложен файл: 8834027.xlsb (54.6 Kb)

Ответить

Дата: Суббота, 04.09.2021, 14:18 | Сообщение № 8

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

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

Сообщений: 19404

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

Замечаний: ±

Excel 365 & Mac Excel

Цитата micholap_denis, 04.09.2021 в 11:57, в сообщении № 7 (

)

чтоб вставлялись не все столбцы

Проще всего скопировать лист целиком, потом удалить ненужное.
[p.s.]Саму разбивку не исправляла, хотя думаю, что можно найти более оптимальный способ[/p.s.]

К сообщению приложен файл: 8589904.xlsb (53.9 Kb)

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Дата: Суббота, 04.09.2021, 16:21 | Сообщение № 9

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

[

Сообщение отредактировал micholap_denis - Суббота, 04.09.2021, 16:58

Ответить

Дата: Суббота, 04.09.2021, 17:05 | Сообщение № 10

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

Pelena, спасибо большое
отпишусь

Ответить

Дата: Понедельник, 06.09.2021, 10:08 | Сообщение № 11

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

Pelena,
в примере все отлично пашет, а в оригинальном файле при копировании листа сохраняются макросы из файла и реагируют на
[vba]

Код

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

[/vba]

как подправить чтоб при копировании листа (с которого потом разбиваются на балансы) макросы не копировались или на это событие не реагировали

Ответить

Дата: Понедельник, 06.09.2021, 10:15 | Сообщение № 12

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

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

Сообщений: 19404

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

Замечаний: ±

Excel 365 & Mac Excel

Сохраняйте сразу в xlsx

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Дата: Понедельник, 06.09.2021, 10:22 | Сообщение № 13

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

Pelena, извиняюсь
разобрался....добавил макрос удаления макросов
[vba]

Код

Sub d()
Dim wb As Workbook, iVBComponent
Sheets("ФБ").Copy

    Set wb = ActiveWorkbook
    For Each iVBComponent In wb.VBProject.VBComponents
        With iVBComponent
            Select Case .Type
                Case 1 To 3: .Collection.Remove iVBComponent
                Case 100: .CodeModule.DeleteLines 1, .CodeModule.CountOfLines
            End Select
        End With
    Next
End Sub

[/vba]

Ответить

Дата: Пятница, 17.09.2021, 20:15 | Сообщение № 14

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

Pelena, подскажите пожалуйста,а как в строчке макроса
[vba]

Код

.Range(.Columns("AK"), .Columns("AK").End(xlToRight)).Delete

[/vba][sub]
указать столбцы , допустим--- AK:АМ; AQ:AS
писал типа --
[vba]

Код

.Range(.Columns("AK:АМ"; "AQ:AS"), .Columns("AK:АМ"; "AQ:AS").End(xlToRight)).Delete

[/vba][sub]
и так тоже
[vba]

Код

.Range(.Columns("AK:АМ", "AQ:AS"), .Columns("AK:АМ", "AQ:AS").End(xlToRight)).Delete

[/vba][sub]
че то не пашет ...
реально не знаю синтаксиса в VBA...нет времени разбираться, все чисто для себя методом тыка и ваших подсказок помощи делаю....

Ответить

Дата: Пятница, 17.09.2021, 20:37 | Сообщение № 15

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

вопрос не только к уважаемой Елене....спасибо всем кто отзовется

Ответить

Дата: Пятница, 17.09.2021, 21:19 | Сообщение № 16

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

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

Сообщений: 19404

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

Замечаний: ±

Excel 365 & Mac Excel

[vba]

Код

.Range("AK:AM,AQ:AS").Delete

[/vba]

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Дата: Пятница, 17.09.2021, 21:34 | Сообщение № 17

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

спаси бо..ща попробую

Ответить

Дата: Пятница, 17.09.2021, 21:39 | Сообщение № 18

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

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

Сообщений: 2797

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

Замечаний: ±

начинал с Excel 4.0, видел 2.1

К колонкам можно адресоваться:
* либо по одиночному буквенному обозначению
* либо по одиночному числовому индексу
* либо по одному буквенному диапазону (буквы через двоеточие)
[vba]

Код

? ActiveSheet.Columns("AK").Address
$AK:$AK
? ActiveSheet.Columns(37).Address
$AK:$AK
? ActiveSheet.Columns("AK:AM").Address
$AK:$AM

[/vba]НЕЛЬЗЯ:
[vba]

Код

Columns(37:39)
Columns("AK:AM,AQ:AS")

[/vba]
У диапазона же может быть составной адрес из нескольких буквенных диапазонов, перечисленных через запятую внутри кавычек. Итоговый диапазон в этом случае представляет собой объединение диапазонов, перчисленных через запятую.
[vba]

Код

? Range("AK:AM,AQ:AS").Address
$AK:$AM,$AQ:$AS

[/vba]Либо возможно пересечение диапазонов - через пробел, например, указанных строк и столбцов:
[vba]

Код

? Range("AK:AM 2:4").Address
$AK$2:$AM$4

[/vba]

МОИ: Ник, Tip box: 41001663842605

Ответить

Дата: Пятница, 17.09.2021, 21:50 | Сообщение № 19

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

спаси бо..ща попробую
Gustav, спасибо... постараюсь запомнить.

Ответить

Дата: Пятница, 17.09.2021, 22:26 | Сообщение № 20

Группа: Проверенные

Ранг: Обитатель

Сообщений: 341

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

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

Excel 2013

Gustav, Pelena, а в примере почемуто
[vba]

Код

.Range("AK:AM,AQ:AS").Delete

[/vba]

ошибку выдает

Ответить

вставка не всех столбцов в новую книгу (Макросы/Sub)

Страница 1 из 2
1
2
»

© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!