|
Внимание, важное сообщение: Дорогие Друзья!
В ноябре далекого 2001 года мы решили создать сайт и форум, которые смогут помочь как начинающим, так и продвинутым пользователям разобраться в операционных системах. В 2004-2006г наш проект был одним из самых крупных ИТ ресурсов в рунете, на пике нас посещало более 300 000 человек в день! Наша документация по службам Windows и автоматической установке помогла огромному количеству пользователей и сисадминов. Мы с уверенностью можем сказать, что внесли большой вклад в развитие ИТ сообщества рунета. Но... время меняются, приоритеты тоже. И, к сожалению, пришло время сказать До встречи! После долгих дискуссий было принято решение закрыть наш проект. 1 августа форум переводится в режим Только чтение, а в начале сентября мы переведем рубильник в положение Выключен Огромное спасибо за эти 24 года, это было незабываемое приключение. Сказать спасибо и поделиться своей историей можно в данной теме. С уважением, ваш призрачный админ, BigMac... |
|
| Компьютерный форум OSzone.net » Программирование, базы данных и автоматизация действий » Программирование и базы данных » VBA - Копирование n столбцов на новый лист с заданными заголовками |
|
|
VBA - Копирование n столбцов на новый лист с заданными заголовками
|
|
Старожил Сообщения: 329 |
Как реализовать функцию на море столбцов?
А то переписывать одно и тоже под конкретную задачу не хорошо Public Sub Copy4Columns(Sheets_ As String, column1 As String, column2 As String, column3 As String, column4 As String) 'копируем на новый лист 4 столбца
Application.ScreenUpdating = False
If ActiveSheet.Index > 1 Then
Sheets.Add Before:=Sheets(ActiveSheet.Index)
Else
Sheets.Add After:=Sheets(ActiveSheet.Index)
End If
ActiveSheet.Name = Sheets_
With Worksheets(ActiveSheet.Index - 1)
oboz = .Cells.Find(What:=column1, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column
.Columns(oboz).Copy
Columns(1).Select
ActiveSheet.Paste
nop = .Cells.Find(What:=column2, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column
.Columns(nop).Copy
Columns(2).Select
ActiveSheet.Paste
razr = .Cells.Find(What:=column3, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column
.Columns(razr).Copy
Columns(3).Select
ActiveSheet.Paste
Tpz = .Cells.Find(What:=column4, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column
.Columns(Tpz).Copy
Columns(4).Select
ActiveSheet.Paste
End With
Application.ScreenUpdating = True
End Sub
|
|
|
Отправлено: 15:33, 04-05-2017 |
|
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать blackeangel, добавили лист по Sheets.Add() — сразу берите возвращаемую методом ссылку на новый рабочий лист и работайте с ней. И никаких последующих игр с ActiveSheet и Worksheets(ActiveSheet.Index - 1).
Будет проще, если Вы поясните, что означает: И пример вызова процедуры покажите. |
|
Отправлено: 16:52, 04-05-2017 | #2 |
|
Старожил Сообщения: 329
|
Профиль | Отправить PM | Цитировать Цитата Iska:
2. Ищем столбец на предыдущем листе по его заголовку, копируем весь столбец и вставляем на новый 3. Пример вызова Copy4Columns("Имя_Нового_Листа","имя_столбца1","Имя_столбца2","Имя_столбца3","имя_столбца4") |
|
|
Отправлено: 16:56, 04-05-2017 | #3 |
|
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать Цитата blackeangel:
.Попробуйте так: Скрытый текст
Option Explicit
Sub SampleCall()
Copy4Columns "Имя_Нового_Листа", Array("имя_столбца1", "Имя_столбца2", "Имя_столбца3", "имя_столбца4")
End Sub
Public Sub Copy4Columns(strNewWorksheetName As String, arrTitles As Variant)
Dim objSourceWorksheet As Worksheet
Dim objDestWorksheet As Worksheet
Dim strTitle As Variant
Dim objSourceRange As Range
Dim objDestRange As Range
Application.ScreenUpdating = False
Set objSourceWorksheet = ActiveSheet
If objSourceWorksheet.Index > 1 Then
Set objDestWorksheet = Sheets.Add(Before:=objSourceWorksheet)
Else
Set objDestWorksheet = Sheets.Add(After:=objSourceWorksheet)
End If
With objDestWorksheet
.Name = strNewWorksheetName
For Each strTitle In arrTitles
Set objSourceRange = objSourceWorksheet.UsedRange.Find(What:=strTitle, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
If Not objSourceRange Is Nothing Then
If .UsedRange.Count = 1 Then
Set objDestRange = .UsedRange.EntireColumn
Else
Set objDestRange = .UsedRange.Offset(ColumnOffset:=1).EntireColumn
End If
If Not objSourceRange.EntireColumn.Copy(objDestRange) Then
Debug.Print "Can't copy column [" & objSourceRange.EntireColumn.Address(External:=True) & "] into worksheet [" & .Name & "]."
End If
Else
Debug.Print "Can't find value [" & strTitle & "] in worksheet [" & objSourceWorksheet.Name & "]."
End If
Next
End With
Set objDestWorksheet = Nothing
Set objSourceWorksheet = Nothing
Application.ScreenUpdating = True
End Sub
Цитата blackeangel:
|
||
|
Отправлено: 17:32, 04-05-2017 | #4 |
|
Старожил Сообщения: 329
|
Профиль | Отправить PM | Цитировать Iska, не, так кривоватенько)
во первых, заменяет последним столбцом все предыдущие Второе, берет не нужный лист, тк мне надо index-1, но это бог с ним, не проблема, а вот с первым беда. По первой проблеме-видимо надо завязываться на кол-во элементов массива заголовков. И вставлять их по очереди в определенный столбец, который равен порядковому номеру заголовка столбца+1 в массиве. Как это реализовать в коде - не допер, тк не понятно где кто копируется и вставляется. И ещё вопрос, как вставить лист, так чтоб он был неактивным? |
|
|
Последний раз редактировалось blackeangel, 05-05-2017 в 12:21. Отправлено: 07:21, 05-05-2017 | #5 |
|
Старожил Сообщения: 329
|
Профиль | Отправить PM | Цитировать Мой вариант решения задачи таков:
Public Sub Copy4Columns2(Sheets_ As String, arrTitles As Variant) 'копируем на новый лист n столбцов
Dim strTitle As Variant
Application.ScreenUpdating = False
If ActiveSheet.Index > 1 Then
Sheets.Add Before:=Sheets(ActiveSheet.Index)
Else
Sheets.Add After:=Sheets(ActiveSheet.Index)
End If
ActiveSheet.Name = Sheets_
i = 0
For Each strTitle In arrTitles
i = i + 1
With Worksheets(ActiveSheet.Index - 1)
oboz = .Cells.Find(What:=strTitle, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column
.Columns(oboz).Copy
Columns(i).Select
ActiveSheet.Paste
End With
Next
Application.ScreenUpdating = True
End Sub
|
|
Отправлено: 12:53, 05-05-2017 | #6 |
|
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать Цитата blackeangel:
. Но ошибка присутствует, надо заменить в ветви Else:на: Set objDestRange = .Columns.Item(.UsedRange.Columns.Count).Offset(ColumnOffset:=1).EntireColumn Цитата blackeangel:
Цитата blackeangel:
Цитата blackeangel:
продолжаете пользовать. |
||||
|
Отправлено: 18:40, 05-05-2017 | #7 |
|
Старожил Сообщения: 329
|
Профиль | Отправить PM | Цитировать Iska, последний вопрос был общим, не относящийся к данной теме.
На счёт порочного круга - мне так понятно что происходит, а ваш код темный лес, ибо знаний в этом направлении у меня нет вообще. Цитата:
|
|
|
Последний раз редактировалось blackeangel, 05-05-2017 в 21:10. Отправлено: 20:57, 05-05-2017 | #8 |
|
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать Цитата blackeangel:
Цитата blackeangel:
Можете также, временно закомментировав Application.ScreenUpdating, прогнать код по шагам под отладчиком по F8, просматривая по ходу движения потребное хоть ручками в окне Immediate, хоть в окне Watches: Скрытый текст
|
||
|
Отправлено: 21:36, 05-05-2017 | #9 |
|
|
Участник сейчас на форуме |
|
Участник вне форума |
![]() |
Автор темы |
![]() |
Сообщение прикреплено |
| |||||
| Название темы | Автор | Информация о форуме | Ответов | Последнее сообщение | |
| 2010 - [решено] Excel 2010 фильтр 1 и 2 листа скопировать на новый лист | The Off | Microsoft Office (Word, Excel, Outlook и т.д.) | 30 | 03-08-2013 09:18 | |
| 2007 - Копирование Строки на Другой лист. | HomaOne | Microsoft Office (Word, Excel, Outlook и т.д.) | 10 | 19-07-2013 22:07 | |
| 2010 - [решено] Excel - копирование выбранных строк на другой лист | linkwy | Microsoft Office (Word, Excel, Outlook и т.д.) | 3 | 16-08-2012 21:14 | |
| VBS/WHS/JS - Как открыть окно проводника с ЗАДАННЫМИ координатами расположения на рабочем столе? | Alex Cop | Программирование и базы данных | 3 | 18-07-2008 12:28 | |
|