Sub Copy_value()
my_row = ActiveCell.Row
my_col = (Cells(my_row, 100).End(xlToLeft).Column) + 1
current_value = Cells(my_row, 4).Value
If my_col < 9 Then
my_col = 9
End If
Cells(my_row, my_col).Value = current_value
End Sub
Sub Slect_range()
lastColumn = Sheets(1).Cells(1, 100).End(xlToLeft).Column
lastRow = Sheets(1).Cells(1000, 1).End(xlUp).Row
Call Add_sheets(lastColumn, lastRow)
End Sub
Sub Add_sheets(col, rows)
For mRow = 1 To rows
cell_value = Sheets("Лист1").Cells(mRow, col).Value
sheet_name = Str(mRow) & "_" & cell_value
On Error Resume Next
cheker = Sheets(sheet_name).Name
If cheker = sheet_name Then
Sheets(sheet_name).Cells(1, 1).Value = cell_value
GoTo next_row
Else
Sheets.Add(After:=Sheets(Sheets.Count)).Name = sheet_name
Sheets(sheet_name).Cells(1, 1).Value = cell_value
End If
next_row:
Next mRow
End Sub
Если лист с именем "Номер_Название" есть, то в "А1" добавляется содержимое с Листа1. Если листа с именем "Номер_Название" нет, то создается такой лист и в "А1" добавляется содержимое с Листа1.
Sub Slect_range()
lastColumn = Sheets(1).Cells(1, 100).End(xlToLeft).Column
lastRow = Sheets(1).Cells(1000, 1).End(xlUp).Row
Call Add_sheets(lastColumn, lastRow)
End Sub
Sub Add_sheets(col, rows)
For mRow = 1 To rows
sheet_name = Sheets("Лист1").Cells(mRow, col).Value
sheet_name = Str(mRow) & "_" & sheet_name
On Error Resume Next
cheker = Sheets(sheet_name).Name
If cheker = sheet_name Then
GoTo next_row
Else
Sheets.Add(After:=Sheets(Sheets.Count)).Name = sheet_name
Sheets(sheet_name).Cells(1, 1).Value = sheet_name
End If
next_row:
Next mRow
End Sub
vikttur написал: PDO , рано Вам еще в этом разделе брать заказы. См. правила этой ветеки и дополнения к ним
Т.е. помогать за бесплатно не рано, лол,а за платно рано? И вас не смещает, что через одну тему, берут заказы люди, которые после бегут узнавать как создать переменную типа "объект". Но раз правило, то что уж, пойду на апворк)
Ну как пример, в тестовый файл вписать строку if date = 123 then: exit sub. Файл без этого кода высылать уже после оплаты, плюс поставить защиту на код.
Как вариант сделай рядом столбцы с выпадающим списком да/нет и повесь на значение условие/правило (что если да один цвет, если нет другой), тогда и формулой "если" можно будет вытянуть значение. А адрес ячейки тоже есть стандартная формула, вроде бы.
Как реализовать? Макросом. Логика примерно такая: если число n = n-1 то x = x+1, где: "n" это текущие число, "n-1" - предыдущие, а "x" это счетчик т.е. длинна серии. Если x>1 то что-то делаем с "x" и "n".
Sub mmmmm()
Application.ScreenUpdating = False
Dim Put_File, PAPKA, STROKA, NOMER As Variant
Dim II As Integer
Range("F2:G65000").Select
Selection.Delete Shift:=xlUp
For i = 2 To 100
PAPKA = Trim(Cells(i, 1).Value)
Put_File = PAPKA + "\"
Dim FS, KATALOG, FILE, MASSIV As Object
Set FS = CreateObject("Scripting.FileSystemObject")
Set KATALOG = FS.GetFolder(Put_File)
Set MASSIV = KATALOG.Files
STROKA = i
NOMER = 1
For Each FILE In MASSIV '
Cells(STROKA, 7).Value = Cells(STROKA, 7).Value & vbNewLine & FILE
Next
Next i
MsgBox "READY"
Application.ScreenUpdating = True
End Sub
Можно попробовать так, думаю норм (в том макросе забыл поправить номер строки).
Sub mmmmm()
Application.ScreenUpdating = False
Dim Put_File, PAPKA, STROKA, NOMER As Variant
Dim II As Integer
Range("F2:G65000").Select
Selection.Delete Shift:=xlUp
For i = 2 To 100
PAPKA = Trim(Cells(i, 1).Value)
Put_File = PAPKA + "\"
Dim FS, KATALOG, FILE, MASSIV As Object
Set FS = CreateObject("Scripting.FileSystemObject")
Set KATALOG = FS.GetFolder(Put_File)
Set MASSIV = KATALOG.Files
STROKA = 2
NOMER = 1
For Each FILE In MASSIV '
Cells(STROKA, 7).Value = Cells(STROKA, 7).Value & vbNewLine & FILE
Next
Next i
MsgBox "READY"
Application.ScreenUpdating = True
End Sub
Как вариант, макросом, другой вариант это через формулы, что-то типа через ЕСЛИ, но я не уверен что через нее можно. Для меня макросом проще.
Код
Sub juxtaposition()
a = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 0)
b = Array("A", "B", "C", "D", "E", "", "", "", "", "")
For i = 2 To 1000
Set myCell = Cells(i, 5)
Set My2Cell = myCell.Offset(0, 1)
If myCell.Value = a(0) Then
My2Cell.Value = b(0)
End If
If myCell.Value = a(1) Then
My2Cell.Value = b(1)
End If
If myCell.Value = a(2) Then
My2Cell.Value = b(2)
End If
If myCell.Value = a(3) Then
My2Cell.Value = b(3)
End If
If myCell.Value = a(4) Then
My2Cell.Value = b(4)
End If
If myCell.Value = a(5) Then
My2Cell.Value = b(5)
End If
Next i
End Sub
Включи запись макроса и поменяй цвет слова,ну а дальше, наверное, сам разберешься.
П.С. Как я понимаю, что бы выбрать слово целиком, нужно содержимое ячейки загнать в массив, после чего проверить массив на вхождение искомого, после чего выбрать тот элемент который подошел под условие, найти в ячейке этот элемент и уже тому что ты нашел нужно придать нужный цвет, тем методом который ты узнаешь записав макрос макрорекодором
YTD это же сумма чего-то с начала года до сегодняшнего дня(ну или до какой-либо даты), так ведь? Т.е. нам нужно просто сложить те показатели, которые мы рассматриваем, если нужны проценты то да, это будет сумма по процентам.
Что складывать, это вопрос не совсем в плоскости экселя)
На Ютубе очень много видео на тему сводных таблиц, лучше всего поискать там. умные таблицы там же.) п.с. умная таблица просто будет новые записи автоматически добавлять в сводную)
Как вариант загнать весь диапазон в массив, и начать сравнивать, в зависимости от положения начальной точки и каких-то условий двигаться, т.е. по сути производить сравнение элементов массива с конечной точкой, соответственно массив должен быть, как минимум двумерным (координаты х,у).
Конечно не работает, это просто пример того как найти первую пустую ячейку. Если нужно скопировать то Логика работы кода, предполагает что при запуске макроса вы находитесь на втором листе.