Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

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

 

= Мир MS Excel/Сортировка вакансий по сотрудникам - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сортировка вакансий по сотрудникам (Макросы/Sub)
Сортировка вакансий по сотрудникам
rikitiki Дата: Суббота, 24.02.2018, 22:45 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Добрый вечер!
Нужна помощь в составлении условия.
Имеется таблица соискателей/вакансий. Количество строк и столбцов может меняться.
1) Нужно найти сумму по столбцам
2) После нужно найти минимальное значение в столбце (с максимальным значением)
3) После нахождения минимального значения вакансия привязывается к соискателю
4) После исключается столбец с максимальным значением и вакансия
5) Повторяется аналогичное действие с оставшимися соискателями и вакансиями
6) Необходимо сопоставить в таблице значения соискателя с его вакансии
 
Ответить
СообщениеДобрый вечер!
Нужна помощь в составлении условия.
Имеется таблица соискателей/вакансий. Количество строк и столбцов может меняться.
1) Нужно найти сумму по столбцам
2) После нужно найти минимальное значение в столбце (с максимальным значением)
3) После нахождения минимального значения вакансия привязывается к соискателю
4) После исключается столбец с максимальным значением и вакансия
5) Повторяется аналогичное действие с оставшимися соискателями и вакансиями
6) Необходимо сопоставить в таблице значения соискателя с его вакансии

Автор - rikitiki
Дата добавления - 24.02.2018 в 22:45
abtextime Дата: Воскресенье, 25.02.2018, 00:02 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 828
Репутация: 117 ±
Замечаний: 0% ±

Excel 2010
Нужен, как минимум, Excel-файл-пример, в котором Вам следует представить какие-то более-менее типичные данные и показать (ввести ручками), какой результат для этого набора данных Вы ожидаете
 
Ответить
СообщениеНужен, как минимум, Excel-файл-пример, в котором Вам следует представить какие-то более-менее типичные данные и показать (ввести ручками), какой результат для этого набора данных Вы ожидаете

Автор - abtextime
Дата добавления - 25.02.2018 в 00:02
rikitiki Дата: Воскресенье, 25.02.2018, 00:16 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Файл
К сообщению приложен файл: 6824515.xlsx(9.6 Kb)
 
Ответить
СообщениеФайл

Автор - rikitiki
Дата добавления - 25.02.2018 в 00:16
abtextime Дата: Воскресенье, 25.02.2018, 17:31 | Сообщение № 4
Группа: Проверенные
Ранг: Ветеран
Сообщений: 828
Репутация: 117 ±
Замечаний: 0% ±

Excel 2010
Пробуйте, вроде работает.

Запускайте StepCall

[vba]
Код
Public Sub Step(R As Range, Target As Range)
Dim A(1 To 100, 1 To 100) As Variant, S(1 To 100) As String, V(1 To 100) As String, ASum(1 To 100) As Variant

    
    RCC = R.Columns.Count - 1
    RRC = R.Rows.Count - 1
    For i = 1 To RRC
        V(i) = R.Cells(i + 1, 1).Value
    Next i
    For j = 1 To RCC
        S(j) = R.Cells(1, j + 1).Value
    Next j
    For j = 1 To RCC
        For i = 1 To RRC
            A(i, j) = R.Cells(i + 1, j + 1).Value
        Next i
    Next j
    
    
    Do While RRC > 0 And RCC > 0
    
    For j = 1 To RCC
        ASum(j) = 0
        For i = 1 To RRC
            ASum(j) = ASum(j) + A(i, j)
        Next i
    Next j
     
    JMax = 0
    AMax = 0
    For j = 1 To RCC
        If ASum(j) > AMax Then
            AMax = ASum(j)
            JMax = j
        End If
    Next j
    
    MinMax = 100000
    For i = 1 To RRC
        If A(i, JMax) < MinMax Then
            MinMax = A(i, JMax)
            IMax = i
        End If
    Next i
    
    Counter = Counter + 1
    
    Target.Cells(Counter, 1).Value = V(IMax)
    Target.Cells(Counter, 2).Value = S(JMax)
    
    For i = IMax To RRC - 1
        For j = 1 To RCC
            A(i, j) = A(i + 1, j)
        Next j
        V(i) = V(i + 1)
    Next i
    RRC = RRC - 1
    
    For j = JMax To RCC - 1
        For i = 1 To RRC
            A(i, j) = A(i, j + 1)
        Next i
        S(j) = S(j + 1)
    Next j
    RCC = RCC - 1
     
Loop
    
End Sub

Public Sub StepCall()
    Call Step(Range("A1:F5"), Range("P2"))
    Range("P2:Q5").Select
    ActiveWorkbook.Worksheets("Ëèñò2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Ëèñò2").Sort.SortFields.Add Key:=Range("P2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Ëèñò2").Sort
        .SetRange Range("P2:Q5")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
[/vba]
К сообщению приложен файл: 6824515_otl.xlsm(23.9 Kb)
 
Ответить
СообщениеПробуйте, вроде работает.

Запускайте StepCall

[vba]
Код
Public Sub Step(R As Range, Target As Range)
Dim A(1 To 100, 1 To 100) As Variant, S(1 To 100) As String, V(1 To 100) As String, ASum(1 To 100) As Variant

    
    RCC = R.Columns.Count - 1
    RRC = R.Rows.Count - 1
    For i = 1 To RRC
        V(i) = R.Cells(i + 1, 1).Value
    Next i
    For j = 1 To RCC
        S(j) = R.Cells(1, j + 1).Value
    Next j
    For j = 1 To RCC
        For i = 1 To RRC
            A(i, j) = R.Cells(i + 1, j + 1).Value
        Next i
    Next j
    
    
    Do While RRC > 0 And RCC > 0
    
    For j = 1 To RCC
        ASum(j) = 0
        For i = 1 To RRC
            ASum(j) = ASum(j) + A(i, j)
        Next i
    Next j
     
    JMax = 0
    AMax = 0
    For j = 1 To RCC
        If ASum(j) > AMax Then
            AMax = ASum(j)
            JMax = j
        End If
    Next j
    
    MinMax = 100000
    For i = 1 To RRC
        If A(i, JMax) < MinMax Then
            MinMax = A(i, JMax)
            IMax = i
        End If
    Next i
    
    Counter = Counter + 1
    
    Target.Cells(Counter, 1).Value = V(IMax)
    Target.Cells(Counter, 2).Value = S(JMax)
    
    For i = IMax To RRC - 1
        For j = 1 To RCC
            A(i, j) = A(i + 1, j)
        Next j
        V(i) = V(i + 1)
    Next i
    RRC = RRC - 1
    
    For j = JMax To RCC - 1
        For i = 1 To RRC
            A(i, j) = A(i, j + 1)
        Next i
        S(j) = S(j + 1)
    Next j
    RCC = RCC - 1
     
Loop
    
End Sub

Public Sub StepCall()
    Call Step(Range("A1:F5"), Range("P2"))
    Range("P2:Q5").Select
    ActiveWorkbook.Worksheets("Ëèñò2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Ëèñò2").Sort.SortFields.Add Key:=Range("P2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Ëèñò2").Sort
        .SetRange Range("P2:Q5")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
[/vba]

Автор - abtextime
Дата добавления - 25.02.2018 в 17:31
fan-vba Дата: Воскресенье, 25.02.2018, 18:01 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 24
Репутация: 10 ±
Замечаний: 0% ±

Excel 2007
решение задачи по предложенному примеру можно осуществить так, организацию кода в оригинале оставляю за Вами
[vba]
Код
Sub otvet()
Application.ScreenUpdating = False
Dim vak%, isk%, i%, j%, tik%, num1%, num2%, i_row%, i_col%
Dim MyArr() As String, Arr(), s_isk() As String, sum()

vak = 4 'количество вакансий
isk = 5 'количество соискателей

ReDim MyArr(1 To vak, 1 To 2)
For i = 1 To vak
MyArr(i, 1) = Cells(i + 1, 1)
Next i

ReDim s_isk(1 To isk)
For i = 1 To isk
s_isk(i) = Cells(1, i + 1)
Next i

ReDim Arr(1 To isk, 1 To vak)
For i = 1 To vak
For j = 1 To isk
Arr(j, i) = Cells(i + 1, j + 1)
Next j
Next i

ReDim sum(1 To isk)

Do
tik = tik + 1

For i = 1 To isk
sum(i) = 0
Next i

For i = 1 To isk
For j = 1 To vak
sum(i) = sum(i) + Arr(i, j)
Next j
Next i

num1 = 0
For i = 1 To isk
If sum(i) >= num1 Then
num1 = sum(i)
i_row = i
End If
Next i

num2 = Application.Max(sum) + 1

For i = 1 To vak
If Arr(i_row, i) < num2 And Arr(i_row, i) <> 0 Then
num2 = Arr(i_row, i)
i_col = i
End If
Next i

MyArr(i_col, 2) = s_isk(i_row)

For i = 1 To vak
Arr(i_row, i) = 0
Next i

For i = 1 To isk
Arr(i, i_col) = 0
Next i

Loop While tik < vak

For i = 1 To vak
Cells(i + 1, 9) = MyArr(i, 1)
Cells(i + 1, 10) = MyArr(i, 2)
Next i

Application.ScreenUpdating = True
End Sub
[/vba]


Сообщение отредактировал fan-vba - Воскресенье, 25.02.2018, 18:02
 
Ответить
Сообщениерешение задачи по предложенному примеру можно осуществить так, организацию кода в оригинале оставляю за Вами
[vba]
Код
Sub otvet()
Application.ScreenUpdating = False
Dim vak%, isk%, i%, j%, tik%, num1%, num2%, i_row%, i_col%
Dim MyArr() As String, Arr(), s_isk() As String, sum()

vak = 4 'количество вакансий
isk = 5 'количество соискателей

ReDim MyArr(1 To vak, 1 To 2)
For i = 1 To vak
MyArr(i, 1) = Cells(i + 1, 1)
Next i

ReDim s_isk(1 To isk)
For i = 1 To isk
s_isk(i) = Cells(1, i + 1)
Next i

ReDim Arr(1 To isk, 1 To vak)
For i = 1 To vak
For j = 1 To isk
Arr(j, i) = Cells(i + 1, j + 1)
Next j
Next i

ReDim sum(1 To isk)

Do
tik = tik + 1

For i = 1 To isk
sum(i) = 0
Next i

For i = 1 To isk
For j = 1 To vak
sum(i) = sum(i) + Arr(i, j)
Next j
Next i

num1 = 0
For i = 1 To isk
If sum(i) >= num1 Then
num1 = sum(i)
i_row = i
End If
Next i

num2 = Application.Max(sum) + 1

For i = 1 To vak
If Arr(i_row, i) < num2 And Arr(i_row, i) <> 0 Then
num2 = Arr(i_row, i)
i_col = i
End If
Next i

MyArr(i_col, 2) = s_isk(i_row)

For i = 1 To vak
Arr(i_row, i) = 0
Next i

For i = 1 To isk
Arr(i, i_col) = 0
Next i

Loop While tik < vak

For i = 1 To vak
Cells(i + 1, 9) = MyArr(i, 1)
Cells(i + 1, 10) = MyArr(i, 2)
Next i

Application.ScreenUpdating = True
End Sub
[/vba]

Автор - fan-vba
Дата добавления - 25.02.2018 в 18:01
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сортировка вакансий по сотрудникам (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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