Макросу надо смотреть, что находится в столбце "Оплачено" и что делать со столбцом "PRICE"? Или чтобы строка не участвовала в сводной?
Если в столбце оплачено есть сумма равная или превышающая столбец price, то данный пункт не участвует в сводной таблице. в сводной таблице участвуют те пункты у которых оплачено стоит 0.
Каратаев да вы все правильно поняли если в столбце (products.NAME) нет слова staff, то данный пункт считается за минусом 50% столбца Price
Макросу надо смотреть, что находится в столбце "Оплачено" и что делать со столбцом "PRICE"? Или чтобы строка не участвовала в сводной?
Если в столбце оплачено есть сумма равная или превышающая столбец price, то данный пункт не участвует в сводной таблице. в сводной таблице участвуют те пункты у которых оплачено стоит 0.Mordor
Dim shRes As Worksheet, shSvod As Worksheet, sh As Worksheet, PivTable As PivotTable Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set shRes = Worksheets.Add(After:=Worksheets(Worksheets.Count)) For i = 1 To Worksheets.Count - 1 Set sh = Worksheets(i) If i = 1 Then sh.usedrange.Copy shRes.Range("A1").PasteSpecial xlPasteAll shRes.Range("A1").PasteSpecial xlPasteColumnWidths Else lr = shRes.usedrange.Rows.Count + 1 sh.usedrange.Offset(1).Copy shRes.Cells(lr, "A").PasteSpecial xlPasteAll shRes.Cells(lr, "A").PasteSpecial xlPasteColumnWidths End If Next i shRes.Columns.WrapText = False
Корректировка_PRICE shRes If Удаление_строк_у_которых_Оплачено_не_равно_нулю(shRes) = False Then Exit Sub End If
Set shSvod = Worksheets.Add(After:=shRes) ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _ SourceData:=shRes.usedrange.Address(ReferenceStyle:=xlR1C1, External:=True), _ Version:=6).CreatePivotTable _ TableDestination:=shSvod.Range("A3").Address(ReferenceStyle:=xlR1C1, External:=True), _ DefaultVersion:=6 Set PivTable = shSvod.PivotTables(1) With PivTable.PivotFields("customers.NAME") .Orientation = xlRowField .Position = 1 End With PivTable.AddDataField PivTable.PivotFields("PRICE"), "Сумма по полю PRICE", xlSum
Application.ScreenUpdating = True
End Sub
Private Sub Корректировка_PRICE(shRes As Worksheet)
Dim arrE(), arrF() Dim var, lr As Long, boolHasStaff As Boolean, i As Long, ii As Long
lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row arrE() = shRes.Range("E2:E" & lr).Value arrF() = shRes.Range("F2:F" & lr).Value For i = 1 To UBound(arrE) boolHasStaff = False If InStr(arrE(i, 1), "Staff") <> 0 Then var = Split(arrE(i, 1), " ") For ii = 0 To UBound(var) If var(ii) = "Staff" Then boolHasStaff = True Exit For End If Next ii If boolHasStaff = False Then arrF(i, 1) = arrF(i, 1) / 2 End If Else arrF(i, 1) = arrF(i, 1) / 2 End If Next i shRes.Range("F2:F" & UBound(arrF)).Value = arrF()
End Sub
Private Function Удаление_строк_у_которых_Оплачено_не_равно_нулю(shRes As Worksheet) As Boolean
Dim arr(), lr As Long, lr2 As Long
lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row arr() = shRes.Range("I2:I" & lr).Value For i = 1 To UBound(arr) If arr(i, 1) <> 0 Then arr(i, 1) = Empty End If Next i shRes.Range("I2:I" & lr).Value = arr() shRes.Sort.Header = xlYes shRes.Sort.SortFields.Add key:=shRes.Columns("I") shRes.Sort.SetRange shRes.Columns("A:I") shRes.Sort.Apply lr = shRes.Cells(shRes.Rows.Count, "I").End(xlUp).Row If lr < 2 Then MsgBox "На всех листах в столбце ""Оплачено"" не нули!", vbInformation Exit Function End If lr2 = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row If lr < lr2 Then shRes.Rows(lr + 1 & ":" & lr2).Delete End If Удаление_строк_у_которых_Оплачено_не_равно_нулю = True
End Function
[/vba]
[vba]
Код
Sub Сводная_с_нескольких_листов()
Dim shRes As Worksheet, shSvod As Worksheet, sh As Worksheet, PivTable As PivotTable Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set shRes = Worksheets.Add(After:=Worksheets(Worksheets.Count)) For i = 1 To Worksheets.Count - 1 Set sh = Worksheets(i) If i = 1 Then sh.usedrange.Copy shRes.Range("A1").PasteSpecial xlPasteAll shRes.Range("A1").PasteSpecial xlPasteColumnWidths Else lr = shRes.usedrange.Rows.Count + 1 sh.usedrange.Offset(1).Copy shRes.Cells(lr, "A").PasteSpecial xlPasteAll shRes.Cells(lr, "A").PasteSpecial xlPasteColumnWidths End If Next i shRes.Columns.WrapText = False
Корректировка_PRICE shRes If Удаление_строк_у_которых_Оплачено_не_равно_нулю(shRes) = False Then Exit Sub End If
Set shSvod = Worksheets.Add(After:=shRes) ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _ SourceData:=shRes.usedrange.Address(ReferenceStyle:=xlR1C1, External:=True), _ Version:=6).CreatePivotTable _ TableDestination:=shSvod.Range("A3").Address(ReferenceStyle:=xlR1C1, External:=True), _ DefaultVersion:=6 Set PivTable = shSvod.PivotTables(1) With PivTable.PivotFields("customers.NAME") .Orientation = xlRowField .Position = 1 End With PivTable.AddDataField PivTable.PivotFields("PRICE"), "Сумма по полю PRICE", xlSum
Application.ScreenUpdating = True
End Sub
Private Sub Корректировка_PRICE(shRes As Worksheet)
Dim arrE(), arrF() Dim var, lr As Long, boolHasStaff As Boolean, i As Long, ii As Long
lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row arrE() = shRes.Range("E2:E" & lr).Value arrF() = shRes.Range("F2:F" & lr).Value For i = 1 To UBound(arrE) boolHasStaff = False If InStr(arrE(i, 1), "Staff") <> 0 Then var = Split(arrE(i, 1), " ") For ii = 0 To UBound(var) If var(ii) = "Staff" Then boolHasStaff = True Exit For End If Next ii If boolHasStaff = False Then arrF(i, 1) = arrF(i, 1) / 2 End If Else arrF(i, 1) = arrF(i, 1) / 2 End If Next i shRes.Range("F2:F" & UBound(arrF)).Value = arrF()
End Sub
Private Function Удаление_строк_у_которых_Оплачено_не_равно_нулю(shRes As Worksheet) As Boolean
Dim arr(), lr As Long, lr2 As Long
lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row arr() = shRes.Range("I2:I" & lr).Value For i = 1 To UBound(arr) If arr(i, 1) <> 0 Then arr(i, 1) = Empty End If Next i shRes.Range("I2:I" & lr).Value = arr() shRes.Sort.Header = xlYes shRes.Sort.SortFields.Add key:=shRes.Columns("I") shRes.Sort.SetRange shRes.Columns("A:I") shRes.Sort.Apply lr = shRes.Cells(shRes.Rows.Count, "I").End(xlUp).Row If lr < 2 Then MsgBox "На всех листах в столбце ""Оплачено"" не нули!", vbInformation Exit Function End If lr2 = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row If lr < lr2 Then shRes.Rows(lr + 1 & ":" & lr2).Delete End If Удаление_строк_у_которых_Оплачено_не_равно_нулю = True
Mordor, Изменения чисто внутренние были, вы удалили столбцы из исходных таблиц, а в Power Query были прописаны действия с ними поименно. Это я изменил. Смотрите в настройках PowerQuery
Еще раз, Power Query объединяет две исходных таблицы в одну и считает итоговые суммы по каждому. лист итог, или как его там, я не трогал вовсе.
Mordor, Изменения чисто внутренние были, вы удалили столбцы из исходных таблиц, а в Power Query были прописаны действия с ними поименно. Это я изменил. Смотрите в настройках PowerQuery
Еще раз, Power Query объединяет две исходных таблицы в одну и считает итоговые суммы по каждому. лист итог, или как его там, я не трогал вовсе.bmv98rus
Замечательный Временно просто медведь , процентов на 20.
bmv98rus я их удалил столбцы, что бы файл поместился на сайт, в полном документе будет еще несколько столбцов, ваша модель будет считать коректно? или надо будет что то еще доделывать? т.к. остается вопрос почему в сводной таблице 66 человек а в итоге 58.
bmv98rus я их удалил столбцы, что бы файл поместился на сайт, в полном документе будет еще несколько столбцов, ваша модель будет считать коректно? или надо будет что то еще доделывать? т.к. остается вопрос почему в сводной таблице 66 человек а в итоге 58.Mordor
Сообщение отредактировал Mordor - Среда, 17.01.2018, 10:32
я попробовал но не нашел как в PowerQuery редактировать. в 2016 офисе, смотрел инструкцию и интернете от MS но так ничего и не понял для какого офиса они это писали на 16 не работало.
а что вам мешает включить оба листа в расчеты? если можете сделать и это в ваших силах как специалиста в этой области.
я попробовал но не нашел как в PowerQuery редактировать. в 2016 офисе, смотрел инструкцию и интернете от MS но так ничего и не понял для какого офиса они это писали на 16 не работало.
а что вам мешает включить оба листа в расчеты? если можете сделать и это в ваших силах как специалиста в этой области.Mordor
Сообщение отредактировал Mordor - Среда, 17.01.2018, 12:16
Mordor, Мне кажется на одном языке пишем, но видимо в разных мирах живем. То что на PowerQuery сделано для двух листов и работает. Если у вас 2016, то в все встроено, если нет то нужно установит надстройку управление тут то что сделано сводной таблицей - я не делал и делать не хочу ибо потом все еще хужею
Mordor, Мне кажется на одном языке пишем, но видимо в разных мирах живем. То что на PowerQuery сделано для двух листов и работает. Если у вас 2016, то в все встроено, если нет то нужно установит надстройку управление тут то что сделано сводной таблицей - я не делал и делать не хочу ибо потом все еще хужеюbmv98rus