Добрый день. У меня очень мало опыта в написании макросов, но надо автоматизировать часть ручной работы. Суть задачи: проверка условия в определенной ячейки и если условие соблюдается, то копирование целой строки на новый лист. В файле в столбце I указаны числа, условие такое что, если значение в ячейке больше чем 230000000000, то на новый лист целая строка должна скопироваться, и так по всему файлу. Коллеги, пожалуйста помогите решить данную задачу. Ибо без помощи к сожалению не справляюсь.
Уважаемая администрация, заранее прошу прощения, я не совсем разобрался как проставить корректные хештеги к своей теме.
спасибо
Добрый день. У меня очень мало опыта в написании макросов, но надо автоматизировать часть ручной работы. Суть задачи: проверка условия в определенной ячейки и если условие соблюдается, то копирование целой строки на новый лист. В файле в столбце I указаны числа, условие такое что, если значение в ячейке больше чем 230000000000, то на новый лист целая строка должна скопироваться, и так по всему файлу. Коллеги, пожалуйста помогите решить данную задачу. Ибо без помощи к сожалению не справляюсь.
Уважаемая администрация, заранее прошу прощения, я не совсем разобрался как проставить корректные хештеги к своей теме.
Sub u_912()
Application.ScreenUpdating = False
u = Cells(Rows.Count, "i").End(xlUp).Row For Each c In Range("i1:i" & u) If c > Range("l1").Value Then
v = Sheets("Ëèñò1").Cells(Rows.Count, "a").End(xlUp).Row + 1
Range("a" & c.Row & ":j" & c.Row).Copy Sheets("Ëèñò1").Range("a" & v) EndIf Next
Application.ScreenUpdating = True EndSub
Sub u_912()
Application.ScreenUpdating = False
u = Cells(Rows.Count, "i").End(xlUp).Row For Each c In Range("i1:i" & u) If c > Range("l1").Value Then
v = Sheets("Ëèñò1").Cells(Rows.Count, "a").End(xlUp).Row + 1
Range("a" & c.Row & ":j" & c.Row).Copy Sheets("Ëèñò1").Range("a" & v) EndIf Next
Application.ScreenUpdating = True EndSub
Sub Copy_() Dim arr, i, j, lr
arr = Worksheets("тест").UsedRange ' имя тест заменить на имя листа с исходными данными With Worksheets("Res") ' имя Res заменить на имя листа с результатами
lr = .Cells(Rows.Count, 1).End(xlUp).Row For i = LBound(arr, 1) ToUBound(arr, 1) If arr(i, 9) > 230000000000# Then For j = LBound(arr, 2) ToUBound(arr, 2)
.Cells(lr, j) = arr(i, j) Next j
lr = lr + 1 EndIf Next i EndWith EndSub
SkyLine6299, добрый день! Вариант на массивах:
Sub Copy_() Dim arr, i, j, lr
arr = Worksheets("тест").UsedRange ' имя тест заменить на имя листа с исходными данными With Worksheets("Res") ' имя Res заменить на имя листа с результатами
lr = .Cells(Rows.Count, 1).End(xlUp).Row For i = LBound(arr, 1) ToUBound(arr, 1) If arr(i, 9) > 230000000000# Then For j = LBound(arr, 2) ToUBound(arr, 2)
.Cells(lr, j) = arr(i, j) Next j
lr = lr + 1 EndIf Next i EndWith EndSub
большое спасибо, вариант с массивами самый идеальный. Но возможно ли не указывать лист с исходными данными в ручную? название листа = название файла exel и каждый день формируется новый файл с новым именем. Как можно это изменить в коде макроса? Вот я попробовал чуть доработать код:
Dim sName$, arr, i, j, lr
добавляю новую переменную
sName$
sName = ActiveWorkbook.ActiveSheet.Name
присваиваю ей значение
arr = Worksheets("sName").UsedRange
а вот как одной переменной задать значение другой переменной, не совсем понимаю
большое спасибо, вариант с массивами самый идеальный. Но возможно ли не указывать лист с исходными данными в ручную? название листа = название файла exel и каждый день формируется новый файл с новым именем. Как можно это изменить в коде макроса? Вот я попробовал чуть доработать код:
Dim sName$, arr, i, j, lr
добавляю новую переменную
sName$
sName = ActiveWorkbook.ActiveSheet.Name
присваиваю ей значение
arr = Worksheets("sName").UsedRange
а вот как одной переменной задать значение другой переменной, не совсем понимаюSkyLine6299
Сообщение отредактировал Serge_007 - Понедельник, 04.07.2022, 15:25
Можете просто запускать на активном листе (лист Res автоматически создается)
Sub Copy_() Dim arr, i, j, lr Dim sh
arr = ActiveSheet.UsedRange IfNot WorksheetExists("Res") Then' имя Res заменить на имя листа с результатами Set sh = Worksheets.Add(After:=ActiveSheet)
sh.Name = "Res" EndIf With Worksheets("Res") ' имя Res заменить на имя листа с результатами
lr = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells.Clear For i = LBound(arr, 1) ToUBound(arr, 1) If arr(i, 9) > 230000000000# Then For j = LBound(arr, 2) ToUBound(arr, 2)
.Cells(lr, j) = arr(i, j) Next j
lr = lr + 1 EndIf Next i EndWith EndSub 'https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists Function WorksheetExists(shtName AsString, Optional wb As Workbook) AsBoolean Dim sht As Worksheet
If wb IsNothingThenSet wb = ThisWorkbook OnErrorResumeNext Set sht = wb.Sheets(shtName) OnErrorGoTo0
WorksheetExists = Not sht IsNothing EndFunction
Можете просто запускать на активном листе (лист Res автоматически создается)
Sub Copy_() Dim arr, i, j, lr Dim sh
arr = ActiveSheet.UsedRange IfNot WorksheetExists("Res") Then' имя Res заменить на имя листа с результатами Set sh = Worksheets.Add(After:=ActiveSheet)
sh.Name = "Res" EndIf With Worksheets("Res") ' имя Res заменить на имя листа с результатами
lr = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells.Clear For i = LBound(arr, 1) ToUBound(arr, 1) If arr(i, 9) > 230000000000# Then For j = LBound(arr, 2) ToUBound(arr, 2)
.Cells(lr, j) = arr(i, j) Next j
lr = lr + 1 EndIf Next i EndWith EndSub 'https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists Function WorksheetExists(shtName AsString, Optional wb As Workbook) AsBoolean Dim sht As Worksheet
If wb IsNothingThenSet wb = ThisWorkbook OnErrorResumeNext Set sht = wb.Sheets(shtName) OnErrorGoTo0
WorksheetExists = Not sht IsNothing EndFunction