Оплитане с Excel - some VBA help?

Е, както се казва, всеки някой ден си намира майстора :)
Оказа се обаче, че наистина с формула няма да стане, а ще трябва скрипт за целта. Така че от "Софтуер" идвам да потърся помощ тук.

Задачата е:
На дадено място в таблицата имам списък със записи (имена) и стойности срещу тях. Всеки от тези записи може да се появява повече от веднъж. Въпросът ми е как от тези данни да генерирам нов списък, в който да няма повторения, а срещу всеки запис А (може и Z, в общия случай не се повтарят записите само на една позиция) да бъде сумата от стойностите, стоящи срещу А в списъка източник.

Понеже от това обяснение става още по-объркано, давам и пример.
Списък - източник:
А - 100
B - 50
C - 140
A - 60

Генерираният списък трябва да изглежда така:
А - 160
B - 50
C - 140

Рових какво ли не, но стигнах само до функция за намиране броя на съвпаденията за всяка позиция. Продължавам да ровя, но ако можете да помогнете - ще се радвам да ми спестите едно главоболие повече.

Предварително благодаря!
Philip

Мда, тъкмо щях да ти пиша в "Софтуер", ама видях че си "донесъл" въпроса си тук. ;о) 10х.

Надрасках един скрипт, който даже взе че тръгна. Не знех, че мога да пиша и скриптове за Excel, ама то още не е доказано де. Сигурно има къде къде по-свестни решения, само трябва и някой друг да помогне.

Ето кода:

Private Sub Worksheet_Change(ByVal Target As Range)



  Dim Vertical1 As Integer

  Dim Vertical2 As Integer



  Vertical2 = 1

  While Worksheets("Sheet2").Range("A" & Vertical2) <> ""

    Worksheets("Sheet2").Range("A" & Vertical2) = ""

    Worksheets("Sheet2").Range("B" & Vertical2) = ""

    Vertical2 = Vertical2 + 1

  Wend



  Vertical1 = 1

  While Worksheets("Sheet1").Range("A" & Vertical1) <> ""

    Vertical2 = 1

    While (Worksheets("Sheet2").Range("A" & Vertical2) <> "") And (Worksheets("Sheet1").Range("A" & Vertical1) <> Worksheets("Sheet2").Range("A" & Vertical2))

      Vertical2 = Vertical2 + 1

    Wend

    Worksheets("Sheet2").Range("A" & Vertical2) = Worksheets("Sheet1").Range("A" & Vertical1)

    Worksheets("Sheet2").Range("B" & Vertical2) = Worksheets("Sheet2").Range("B" & Vertical2) + Worksheets("Sheet1").Range("B" & Vertical1)

    Vertical1 = Vertical1 + 1

  Wend



End Sub

Избираш меню "Tools" - "Macros" - "Visual Basic Editor". Като се отвори редактора, отляво избираш "Microsoft Excel Objects" - "Sheet1", и там слагаш кода който е по-нагоре.

Резултата: Във страница първа на Excel в колона "А" пишеш имената на редовете, т.е. "Гергана", "Йорданка" и т.н., а в колона "B" слагаш числовите стойности. При всяка редакция на тази страница се изпълнява този код, и подрежда във втора страница имената в същата последователност, като ако срещне повторения - не слага на нов ред, а добавя към вече съществуващия ред с името в колони A и B.

Дано да работи и при теб, щото определено нямам опит с писане за Excel. Имай впредвид, че на всяка промяна на страница Sheet1, втората страница Sheet2 колони A и B биват изтривани, и се прави отново сбора.

----------------------------------
помислих, хареса ми, помислих пак...

Май ще ми трябват малко допълнителни разяснения по вкарването на кода в действие. Дали защото се опитвам да го приложа към вече направена таблица, в която списъците "източник" и "генериран" са на отделни страници, или друго ме обърква, не знам - а и в 3:15 AM просто ще го оставя за утре - вероятно на ICQ-то, защото ти нямам мейла. Ако разрешаваш и имаш възможност, разбира се.

Philip

Разбира се, че разрешавам. Но това може да стане вечерта, тъй като засега нямам нет в офиса, а съм на работа.

Ако ще прилагаш кода към вече готова таблица - трябва да промениш координатите за колоните от които ще се чете, включително от кой ред ще започва списъка, и също така координатите където ще се генерира изходния резултат. Направил съм ги така, че оригиналният списък да е на 1-ва страница, а генерираният - на втора. Защото е "прихванато" събитието промяна на страница 1. Ако искаш да бъдат на една и съща страница, ще е малко по-сложно, тъй като на всяка промяна на оригиналният, и на генерираният списък се изпълнява това събитие, и се получава зацикляне.

Хайде довечера ще го разнищим, пък ако дотогава мине някой дето наистина да умее да пише на VBA, ще е екстра.

----------------------------------
помислих, хареса ми, помислих пак...

Абе радвам се че се обръщаш към код, ама дали не си пробвал да потърсиш в хелпа щото виж аз какво открих като за човек дето не иска да се занимава с код: On the Tools menu, point to Wizard, and then click Conditional Sum.
Иначе аз бих си го изтъркалял с код

Наведи главата защото прелитам ниско с асконата !!!

Да, и с това съм опитал. Всичко е ОК, но когато сменя една фиксирана стойност за сравнение от стринг на адрес на клетка, формулата започва да показва не сборът на каквото ми трябва, а сборът на всичко минус стойността срещу най-горната клетка.

Пример:
Работещо правилно:
=SUM(IF(Sheet2!$A$4:$A$602="Иван";Sheet2!$C$4:$C$602;0))
Преработени, но проблемни:
=SUM(IF(Sheet2!$A$4:$A$602=A4;Sheet2!$C$4:$C$602;0))
=SUM(IF(Sheet2!$A$4:$A$602=Obobshtenie!A4;Sheet2!$C$4:$C$602;0))

Здрасти Филипе :)
Този макрос работи вярно при мен :)
Дано и на теб да ти свърши работа.
За да можеш да го ползваш направи следното:
1. Отвори Visual Basic Editor (Tools - Macros - Visual Basic Editor)
2. От менюто на Visual Basic Editor избери Insert - Module
3. Copy/Paste кода който съм ти написал по-долу в празния модул който добави
4. За да го стартираш, избираш от менюто на Excel Tools - Macros - Sub_PhilipDudin :))

Ако има някакви бъгове обаждай се :)
Кода изглежда голям, защото съм сложил няколко проверки за валидност на входните данни и доста коментари.

Ето го и макроса, който трябва да Copy/Paste:

Sub Sub_PhilipDudin()



' Sub_PhilipDudin Macro

' Macro recorded 10/14/2003 by LOCALHOST

' Georgi Yordanov Ganchev - GogoX@Lycos.com



On Error Resume Next



 ' Деклариране на необходимите променливи за работа на макроса

Dim objRange As Range

Dim colCollection As New Collection

Dim strSourceRange As String

Dim strSplit() As String

Dim lngSourceColumn As Long

Dim lngSourceStartRow As Long

Dim lngSourceEndRow As Long

Dim strDestinationCell As String

Dim lngDestinationColumn As Long

Dim lngDestinationRow As Long

Dim lngCurrentRow As Long

Dim strCurrentChar As String

Dim curCurrentRowValue As Currency

Dim lngCollectionCounter As Long



 ' Въвеждане на колоната с данните (буквите)

strSourceRange = InputBox("Напиши обхвата на първата колона от таблицата източник (напр. A1:A20)", "Избери обхвата с данните", "A1:A10")

 ' Ако са въведени малки букви да се направят големи. (a1:a20=A1:A20)

strSourceRange = UCase$(strSourceRange)

 ' Премахване на всички интервали от въведения обхват (ако има такива) за да не се получават грешки

strSourceRange = Replace$(strSourceRange, " ", "")

 ' Ако не е въведено нищо да се излезе от макроса

If strSourceRange = "" Then

   Exit Sub

End If

 ' Разделяне на обхвата на части - например "А1:А20"="А1" и "А20"

strSplit = Split(strSourceRange, ":")

 

 ' Определяне номера на колоната по нейната буква. A=1 ; B=2 ; C=3 и т.н. до Z=26. Колони с по две букви (напр. AD) не се поддържат

lngSourceColumn = Asc(Left$(strSplit(0), 1)) - 64

 ' Проверка дали избраната колона е в обхвата от 1 до 26 (от A до Z)

If lngSourceColumn < 1 Or lngSourceColumn > 26 Then

   MsgBox "Невалидна колона. Поддържат се колони в обхвата от A до Z !", vbCritical, "Грешка"

   Exit Sub

End If

 

 ' Определяне на началния ред от колоната. Това е цифрата след първата буква

lngSourceStartRow = Val(Mid$(strSplit(0), 2, Len(strSplit(0))))

 ' Проверка дали избрания начален ред е в обхвата от 1 до 65535

If lngSourceStartRow < 1 Or lngSourceStartRow > 65535 Then

   MsgBox "Невалиден начален ред. Поддържат се  редове в обхвата от 1 до 65535 !", vbCritical, "Грешка"

   Exit Sub

End If



 ' Определяне на крайния ред от колоната. Това е цифрата след втората буква

lngSourceEndRow = Val(Mid$(strSplit(1), 2, Len(strSplit(1))))

 ' Проверка дали избрания начален ред е в обхвата от 1 до 65535

If lngSourceEndRow < 1 Or lngSourceEndRow > 65535 Then

   MsgBox "Невалиден начален ред. Поддържат се  редове в обхвата от 1 до 65535 !", vbCritical, "Грешка"

   Exit Sub

End If





 ' Въвеждане на адреса на началната клетка от където да се попълнят обработените данни

strDestinationCell = InputBox("Въведете адреса на клетката от където да се попълнят обработените данни (напр. А30)", "Избери клетката за резултата", "A30")

  ' Ако са въведени малки букви да се направят големи. (a30=A30)

strDestinationCell = UCase$(strDestinationCell)

 ' Премахване на всички интервали от въведения обхват (ако има такива) за да не се получават грешки

strDestinationCell = Replace$(strDestinationCell, " ", "")

 ' Ако не е въведено нищо да се излезе от макроса

If strDestinationCell = "" Then

   Exit Sub

End If



 ' Определяне на номера на колоната по нейната буква. A=1 ; B=1 ; C=1 и т.н. до Z=26. Колони с по две букви (напр. AD) не се поддържат

lngDestinationColumn = Asc(Left$(strDestinationCell, 1)) - 64

 ' Проверка дали избраната колона е в обхвата от 1 до 26 (от A до Z)

If lngDestinationColumn < 1 Or lngDestinationColumn > 26 Then

   MsgBox "Невалидна колона. Поддържат се колони в обхвата от A до Z !", vbCritical, "Грешка"

   Exit Sub

End If



 ' Определяне на реда на клетката за резултата. Това е цифрата след буквата

lngDestinationRow = Val(Mid$(strDestinationCell, 2, Len(strDestinationCell)))

 ' Проверка дали избрания начален ред е в обхвата от 1 до 65535

 ' Това е малко неправилно, защото ако реда е 65535 ще може да се покаже само една клетка, следващата (65536) не съществува в Excel

 ' Но се предполага че няма да има такива издевателства, все пак този скрипт е за лична употреба

 ' И ако някой не иска той да работи както трябва, ще го направи със или без тази проверка :)

If lngDestinationRow < 1 Or lngDestinationRow > 65535 Then

   MsgBox "Невалиден начален ред. Поддържат се  редове в обхвата от 1 до 65535 !", vbCritical, "Грешка"

   Exit Sub

End If





 ' Вече имаме входните данни и мястото където да поставим резултата

 ' Започваме да обхождаме входните данни и да събираме стойностите

For lngCurrentRow = lngSourceStartRow To lngSourceEndRow

     ' Ще добавяме буквите от първата колона като ключове в колекция

     ' Ако не може да се добави съответната буква, значи вече съществува и се получава грешка

     ' И към нея трябва да се прибави цифрата

     ' Предполага се че цифрата е от тип Currency - Цифри с точност до 4-тия знак. този тип данни се ползва за валута (цифри които представляват някаква сума пари)

     ' Изчистване на грешката ако е имало такава

    Err.Clear

     ' Вземане на поредната буквата (или дума)

    strCurrentChar = ActiveSheet.Cells(lngCurrentRow, lngSourceColumn)

     ' Вземане на стойността от колекцията на тази буква (дума)

    strSplit = Split(colCollection.Item(strCurrentChar), Chr$(1))

     ' Вземане на втория елемент от стойността в колекцията (натрупаната до тук стойност за тази буква/дума)

    curCurrentRowValue = 0

    curCurrentRowValue = Val(strSplit(1))

     ' Ако се получи грешка значи тази буква (дума) я няма

    If Err.Number <> 0 Then

        ' Да се добави в колекцията със стойността от втората колона (колоната вдясно от буквата/думата)

       curCurrentRowValue = 0

       curCurrentRowValue = ActiveSheet.Cells(lngCurrentRow, lngSourceColumn + 1).Value

       colCollection.Add strCurrentChar & Chr$(1) & curCurrentRowValue, strCurrentChar

    Else ' Ако няма грешка значи буквата (думата) съществува

        ' Трябва нейната досегашна стойност да се събере с цифрата в клетката двясно от буквата (думата)

       curCurrentRowValue = curCurrentRowValue + ActiveSheet.Cells(lngCurrentRow, lngSourceColumn + 1).Value

        ' Премахваме буквата (думата) от колекцията

        ' За да можем да я добавим пак с новата й стойност

       colCollection.Remove strCurrentChar

        ' Стойността се добавя по следния начин:

        ' Първо се добавя буквата (думата), после код 1 (Chr$(1)) който ще служи за разделител мяжду буквата (думата) и стойността й и след това стойността

        ' Това се прави защото още не знам как да взема ключа на съответен елемент от колекцията

       colCollection.Add strCurrentChar & Chr$(1) & curCurrentRowValue, strCurrentChar

    End If

Next 'lngCurrentRow



 ' След като сме обходили всички редове от таблицата източник

 ' В колекцията имаме желания резултат

 ' Показваме го в от избраната клетка надолу

 ' Резултатите не са подредени по азбучен ред, това може да се направи със средствата на Excel

For lngCollectionCounter = 1 To colCollection.Count

     ' Разделяне на стойностите записани в колекцията на две части с разделител код 1

    strSplit = Split(colCollection.Item(lngCollectionCounter), Chr$(1))

     ' Първата част е буквата(думата)

    ActiveSheet.Cells(lngDestinationRow + lngCollectionCounter - 1, lngDestinationColumn).Value = strSplit(0)

     ' Втората част е сборната й стойност

    ActiveSheet.Cells(lngDestinationRow + lngCollectionCounter - 1, lngDestinationColumn + 1).Value = strSplit(1)

Next 'lngCollectionCounter



End Sub

И той касае форматирането на кода, който си дал. Не съм писал никога на вб, някаква причина ли има за двойните редове? Не за друго, ама така е доста по-четимо от повечето сорсове, които съм разглеждал (предимно vbs). Това ли е прието като начин за форматиране?

Да... ще се обаждам :)

За кои двойни редове. Не мога да разбера какво питаш и какво не ти харесва във форматирането на кода...

че ти е развалено долното тире

Тоя Steve Howey само да го гепам 82min ще го късаам