Всем привет.
Нужен скрипт для майкрософт эксель 2003 (он лицензионный у меня, ставить более новый не буду, предупреждаю сразу).
Исходные данные:
Открываю файл xls, который выглядит как 2 столбца с произвольными цифрами. Количество строк - может быть до 1000, в среднем около 450-500.
Пример такого файла на рисунке 1 (желтым выделил я для дальнейших пояснений, в реале выделения нет)
Затем запускаю скрипт - который должен сделать:
1. создать новый лист в этом файле.
2. Скопировать в новый лист т.е. числа из 1-й, 6-й, 11-й, 16-й, 21-й и т.д. строк (которые на примере отмечены желтым) - т.е. строку копируем, затем 4 строки пропускаем.
3. Расположить данные так, чтобы они встали в виде таблицы высотой в 22 строки (это важно).
4. Форматирование - выровнять по центру все значения (как по горизонтали, так и по вертикали)
Пример результата работы скрипта - на рисунке 2
(желтое выделение - мое, для наглядности)
Кто возьмется сделать сие за символическую сумму в 500 рублей на телефон?
пишите на почту griggenx()mail.ru,
Денег не надо. Вот код модуля:
Sub Sort()
Dim AX As String
Dim BX As String
Dim last As Long
Dim lasti As Long
Dim XI As String
Dim YI As String
Dim xxI As Integer
Dim yyI As Integer
Dim iterai As Integer
Dim n As Integer
Dim nCharCode As Integer
Dim t As Integer
If SheetExists("Itog") Then
Sheets("Itog").Cells.Delete
Else
Sheets.Add(After:=Sheets(1)).Name = "Itog"
End If
Sheets("Ëèñò1").Select
last = ActiveSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
xxI = yyI = 1
iterai = 1
t = 0
nCharCode = Asc("A")
For x = 1 To last Step 5
AX = "A" + CStr(x)
BX = "B" + CStr(x)
Range(AX, BX).Select
Selection.Copy
Sheets("Itog").Select
If x > 5 Then
If t = 0 Then
lasti = ActiveSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Else
lasti = lasti + 1
End If
Else
lasti = 1
End If
If lasti Mod 22 = 0 Then
nCharCode = nCharCode + 2
iterai = 1
t = 1
End If
Range(Chr(nCharCode) + CStr(iterai)).Select
iterai = iterai + 1
ActiveSheet.Paste
Sheets("Ëèñò1").Select
Next x
Sheets("Itog").Select
Range("A1:B1", "A1:Z22").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1").Select
End Sub
Function SheetExists(SheetName As String) As Boolean
On Error Resume Next
SheetExists = Not Sheets(SheetName) Is Nothing
End Function
Работает до 1.5к записей. Потом идет переполнение по оси X. Общий вариант для любой книги - подумать нужно.
p.s. Специально проверил на 2003 Pro Office. В нем и писал. Аналогично работает в 2013.
Спасибо! С уважением, Александр
Не за что. Хоть вспомнил что такое VBA 😊 😊 😊
p.s. Если кому что надо написать (С/С++/С#/VBA/...) - обращайтесь.