» Excel VBA (часть 3)

А можно еще вопросик?
А если у диапазона, который [h16:I25] есть имя, то как нужно написать макрос, чтобы завязаться на имени диапазона? Пробовал так:

Код: For Each cell In [Диапазон1].Address

Leojse
For Each cell In Range("Диапазон1")

Извините, уже нашел решение.

Добавлено:
andrewkard1980 еще раз спасибо!

Помогите, пожалуйста, как можно сделать так, чтобы исходные данные с этой матрицы.
http://rghost.ru/57398968
сохранились в файл блокнота в таком виде

Код:
ремонт компьютеров -- ремонт ноутбуков {length:5, color:#FF0000, weight:3}
ремонт компьютеров -- компьютерная помощь {length:10, color:#FF0000}
ремонт компьютеров -- ремонт планшетов {length:30}

ремонт ноутбуков -- компьютерная помощь {length:10, color:#FF0000}
ремонт ноутбуков -- ремонт планшетов {length:5, color:#FF0000, weight:3}

компьютерная помощь -- ремонт планшетов {length:10, color:#FF0000}
компьютерная помощь -- ремонт пк {length:70}
компьютерная помощь -- компьютерный сервис {length:50}
компьютерная помощь -- ремонт мониторов {length:150}
компьютерная помощь -- чистка ноутбука {length:110}

ремонт компьютеров на дому -- ремонт пк {length:10, color:#FF0000}
ремонт компьютеров на дому -- компьютерный сервис {length:10, color:#FF0000}
ремонт компьютеров на дому -- компьютерный мастер {length:10, color:#FF0000}
ремонт компьютеров на дому -- ремонт мониторов {length:50}
ремонт компьютеров на дому -- чистка ноутбука {length:5, color:#FF0000, weight:3}

ремонт планшетов -- ремонт пк {length:160}
ремонт планшетов -- ремонт мониторов {length:100}
ремонт планшетов -- чистка ноутбука {length:160}

ремонт пк -- компьютерный сервис {length:10, color:#FF0000}
ремонт пк -- компьютерный мастер {length:20, color:#FF9999}
ремонт пк -- ремонт мониторов {length:20, color:#FF9999}
ремонт пк -- чистка ноутбука {length:30}

компьютерный сервис -- компьютерный мастер {length:5, color:#FF0000, weight:3}
компьютерный сервис -- ремонт мониторов {length:30}
компьютерный сервис -- чистка ноутбука {length:70}

компьютерный мастер -- ремонт мониторов {length:5, color:#FF0000, weight:3}

компьютерный мастер -- чистка ноутбука {length:60}

ремонт мониторов -- чистка ноутбука {length:40}

Futurism
Пробуйте:

Код:
Sub TableToTXT()
Dim rRg As Range
Dim sDist As String

For Each rRg In Worksheets(1).UsedRange
If rRg.Row <> 1 And rRg.Column <> 1 And rRg.Value <> "" Then
Select Case rRg.Value
Case 0: sDist = "{length:5, color:#FF0000, weight:3}"
Case 1: sDist = " {length:10, color:#FF0000}"
Case 2: sDist = "{length:20, color:#FF9999}"
Case 3 To 1000: sDist = "{length:" & rRg.Value * 10 & "}"
End Select

Open "D:\\file.txt" For Append As #1
Print #1, Worksheets(1).Cells(rRg.Row, 1) & " -- " & Worksheets(1).Cells(1, rRg.Column) & " " & sDist
Close #1
End If
Next
End Sub

andrewkard1980
как всегда снимаю шляпу.

Добавлено:
а можно его упорядочить-отсортировать, чтобы сначала шли пары переменных у которых лента 5, потом 10 и по возрастанию.

Futurism
Можно и так:

Код:
Sub TableToTXT()
Dim rRg As Range
Dim sDist As String
Dim aTXT(), lCl&, l&: l = 1

With Worksheets(1)
For Each rRg In .UsedRange
If rRg.Row <> 1 And rRg.Column <> 1 And rRg.Value <> "" Then
Select Case rRg.Value
Case 0: sDist = "{length:5, color:#FF0000, weight:3}"
Case 1: sDist = " {length:10, color:#FF0000}"
Case 2: sDist = "{length:20, color:#FF9999}"
Case 3 To 1000: sDist = "{length:" & rRg.Value * 10 & "}"
End Select

ReDim Preserve aTXT(1 To 2, 1 To l)
aTXT(1, l) = rRg.Value
aTXT(2, l) = .Cells(rRg.Row, 1) & " -- " & .Cells(1, rRg.Column) & " " & sDist
l = l + 1
End If
Next

lCl = .Cells(1, Columns.Count).End(xlToLeft).Column: l = l - 1
.Range(Cells(1, lCl + 1), Cells(l, lCl + 2)) = Application.Transpose(aTXT)

.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Cells(1, lCl + 1), Order:=xlAscending
With .Sort
.SetRange Range(Cells(1, lCl + 1), Cells(l, lCl + 2))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ReDim aTXT(1 To 2, 1 To l)
aTXT = Application.Transpose(.Range(Cells(1, lCl + 1), Cells(l, lCl + 2)))
.Range(Cells(1, lCl + 1), Cells(l, lCl + 2)).ClearContents
For l = 1 To UBound(aTXT, 2)
Open "D:\\file.txt" For Append As #1
Print #1, aTXT(2, l)
Close #1
Next l
End With
End Sub

как всегда гениально.

Добрый вечер, уважаемые форумчане!
Подскажите, пожалуйста, по такому вопросу.
Есть макрос (Макрос1), который ищет некоторые значения в выделенном диапазоне. Потом результат выдает всегда в столбце А начиная с ячейки 3 (то есть результаты появляются с ячейки А3 и далее вниз по столбцу). Потом я эти результаты копирую уже на другой лист также по определенным столбцам. Подскажите, возможно ли написать такую процедуру типа: "Если Макрос1 обработал в Листе1 диапазон В:С, то результат, котрый получен в столбце А перенести на Лист2 в столбец В начиная с ячейки В3." По-моему, непонятно написал, но не могу написать проще.
Заранее спасибо!

Leojse
т.е. если в ячейках А3:Аn Лист1 что то есть, перенести его в Лист2 ячейки В3:Вn, где n - последняя заполненная ячейка?


Код:
Sub CopyL1ToL2()
Dim l&: l = Worksheets("Лист1").Cells(Rows.Count, "A").End(xlUp).Row
If l > 2 Then Worksheets("Лист2").Range("B3:B" & l) = Worksheets("Лист1").Range("A3:A" & l).Value
End Sub

andrewkard1980, да, спасибо большое!

andrewkard1980

а можно код макроса подправить так, чтобы брасывал не в txt а в соседний лист, как матрицу, где
1. в столбец А записывать фразы до « -- »
2. в столбец В записать « -- »
3. в столбец С записывать фразы после « -- »
4. в столбец D записать цифру попранного сходства без указания цвета как {length:цифра}
где как и прежде ноль — это {length:5}, 1 — это {length:10}, 2 — это {length:20} и тд

Кто поможет как реализовать запуск файла с определеного листа
К примеру есть 7 листов, работаю с 6 закрываю открываю 6 а надо чтоб всегда стартовало с 1 например

gogaman
В модуль "ЭтаКнига"


Код:
Private Sub Workbook_Open()
ThisWorkbook.Worksheets(1).Activate
End Sub

andrewkard1980
добро

А такой вопрос.
http://rghost.ru/57521593
Можно написать макрос, который данные в листе вход автоматически преобразует в такой вид, как на листе выход
Например в листе выход в столбец А идет фраза
ремонт компьютеров идет она с А1 по А40 , а в столбце B с какими фразами это фраза встречается. Как видите с 40 фразами
следующая фраза ремонт ноутбуков А41-А80 и те фразы с котором она встретилась.
столбец С это порядковый номер . У нас же с А1-А40 , вот 40 раз и встретилась.
Этот документ вручную делался. хотелось бы, чтоб лист выход в таком виде автоматически создавался.

Futurism
Пробуйте:

Код:
Sub DoTable()
Dim lRw&, lCl&, l&: l = 1

With Worksheets("Вход")
For lCl = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column Step 3
For lRw = 2 To .Cells(Rows.Count, lCl).End(xlUp).Row
Worksheets("Выход").Cells(l, 1) = .Cells(1, lCl).Value
Worksheets("Выход").Cells(l, 2) = .Cells(lRw, lCl).Value
Worksheets("Выход").Cells(l, 3) = lRw - 1
l = l + 1
Next lRw
Next lCl
End With
End Sub

ага, все с работало, как всегда. Дело мастера боится

всем привет.
Нужна помощь...
Исходно есть лист1, лист2 и т.д.
На нем есть данные с примечаниями.
Нужно через функцию копировать содержимое ячеек вместе в примечаниями между листами.
Примеры находил, но они просто переносят содержимое примечания в содержимое ячейки..
Заранее благодарен.

И мне можете помочь
вот в этом файле
http://rusfolder.com/41488235

надо найти соотношения где в ячейки Pearson Chi-square значение p<0,1

например, как на этой картинке

тут p=,007 (h80)
вот эти данные с 68-81 ячейки надо оставить, они ценные.

а вот пример ячейка 45-57 там
Pearson Chi-square имеет значение p=,24

поэтому эти ячейки надо удалить
т.е. по сути надо найти по документу Pearson Chi-square его значение p=,
если оно больше 0,1 удалить табличку, а если меньше оставить. в зависимости от ширины и длины таблички, оно то столбце H, то в столбце F
M-L Chi-square не трогаем)
Можете помочь решить эту задачу.
таблица начинается с фразы 2-Way Summary Table: Observed Frequencies
заканчивается в строчке, где данные по M-L Chi-square

DLysenko
Вот пример, правда работает только с одной ячейкой

Код:
Function CopyAll(r As Range)
CopyAll = r.Value
If Not r.Comment Is Nothing Then
ActiveCell.AddComment
ActiveCell.Comment.Text (r.Comment.Text)
End If
End Function

Цитата:

Когда первый раз прогоните и все подойдет, раскомментируйте строку:
'If lFstRw > 0 Then Rows(lFstRw & ":" & lLstRw).Delete

а как это сделать. пока я проверил, все ок
только вот с А1-13 строчки, там p=,20, а красным цветом он не выделил.
Вы правы, тут все смещено, т.к. была конверсия с rtf 2 xls
вот исходный файл
http://rusfolder.com/41496965
это конечно немного не эксель, а ворд, но тут все более структурировано, таблицы не скачут. Ваш макрос подойдет для такого файла или его переделать надо будет под него.

Добрый вечер!
Подскажите, пожалуйста, можно ли реализовать следующее: в столбцах есть данные, между которыми есть пустые ячейки (Лист "Изначальные данные"). Затем я перекопирую эти же данные, но с пропуском пустых ячеек в этот же Лист "Изначальные данные" (то есть, получаю то, на Листе "Итог"). Можно ли перекопировать данные, игнорируя пустые ячейки в листе "Изначальные данные"? То есть хочется, чтобы данные в Изначальном листе после обработки макросом, шли сплошняком, без разрыва в виде пустых ячеек.
http://rghost.ru/57556561


Добавлено:
Fsp050
раскоментировать - значит убрать апостров перед строчкой кода.

Fsp050
Хоть это и Word, но табличек как таковых в нем нет, это объекты Statistica, которые у меня отображаются как рисунки.

Добавлено:
Leojse
Да, можно, если правильно понял:

Код:
Sub DelBlankCells()
Dim l&
Application.ScreenUpdating = False
With Worksheets("Изначальные данные")
For l = Application.Max(.Cells(Rows.Count, "A").End(xlUp).Row, _
.Cells(Rows.Count, "B").End(xlUp).Row) To 2 Step -1
If .Cells(l, 1).Value = "" Then .Cells(l, 1).Delete Shift:=xlUp
If .Cells(l, 2).Value = "" Then .Cells(l, 2).Delete Shift:=xlUp
Next l
End With
Application.ScreenUpdating = True
End Sub

andrewkard1980
да, Вы правы, почему импорт со статистики дурацкий
придется делать такую схему
сначала в rtf потом в эксель, а потом макрос.
Но тогда такая просьба, можно сделать, чтобы все красные уходили на другой лист
а те что нормальные подвигались друг к другу.

Fsp050

Попробуйте, чуть наоборот получилось на счет:


Цитата:

чтобы все красные уходили на другой лист
а те что нормальные подвигались друг к другу

, но сути вроде не меняет:


Код:
Sub DelTable()
Dim lRw&, lFstRw&, lLstRw&, x&, y&, l As Variant
Dim sStr$, sPCS$

For lRw = 1 To Cells(Rows.Count, "A").End(xlUp).Row
l = Application.Match("*" & "Summary Table" & "*", Range(Cells(lRw, 1), Cells(lRw, 10)), 0)
If Not IsError(l) Then
If l > 1 Then Range(Cells(lRw, 1), Cells(lRw, l - 1)).Delete shift:=xlToLeft
End If
Next lRw

If ThisWorkbook.Worksheets.Count < 2 Then
ThisWorkbook.Worksheets.Add After:=Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Worksheets(1).Activate
End If

For lRw = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
sStr = Cells(lRw, 1).Value
If sStr = "Pearson Chi-square" Then
sPCS = "0." & Mid(Cells(lRw, Cells(lRw, Columns.Count).End(xlToLeft).Column).Value, 4)
If Val(sPCS) < 0.1 Then
lLstRw = lRw + 1
lFstRw = 0: y = lRw
Do Until InStr(1, Cells(y, 1).Value, "2-Way Summary Table") > 0
y = y - 1
lFstRw = y
Loop
Rows(lFstRw & ":" & lLstRw).Copy Destination:=Worksheets(2).Range("A" & Worksheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 3)
Rows(lFstRw & ":" & lLstRw).Delete
End If
End If
Next lRw
End Sub

andrewkard1980
очередной раз спасли.

А можете помочь ещё в решении такой задачи. А именно подбор оптимальных моделей регрессии. Постараюсь задачу объяснить максимально просто
Множественный регрессионный анализ нужен для предсказания значения зависимой переменной через независимые.
Например переменную Y надо предсказать через значение переменных x1,x2,x3
при этом важный показатель это коэф. множ детерминации или R-квадрат.
пример на рисунке.

тут я пытаюсь предсказать значение переменной "дистанцирование" она зависимая через 5 независимых, они справа.
после анализа получаем такой результат

но это откровенная лажа.
т.к. тут R квадрат равен 0,036 хуже некуда и уровень значимости p=0,88
это значит что нельзя предсказать зависимую переменную через эти 5.
другой вариант красивый

здесь у нас такая зависмая переменная и мы её пытаемся предсказать через 6 независимых
вот такой результат

тут R-квадрат равен 0,77 и уровень значимости 0,00
значит зная значения независимых переменных, мы можем предсказать значение зависимой с точностью до 77%.
Но чтобы этого добиться необходимо постоянно перебирать модели.
например пытаясь предсказать Y через x1,x2,x3 у нас плохой R-квадрат.
но если мы изменим независимые переменные на x3,x4,x7,x10 будет хороший r-квадрат
Можно ли в экселе сделать так, чтобы макрос сам находил оптимальный r-квадрат на моих выборках.
например, вот данные со старого исследования
http://rghost.ru/57608064
можно ли перебирать модели пока не будут выбраны оптимальные сочетания зависимых и независимых переменных. на R-квадрат можно смотреть, если он равен хотя бы 0,50
на этом сайте дается решение онлаин одной задачи, т.е просто проведется анализ онлайн
http://math.semestr.ru/regress/excel.php
и то по-левому, там можно выкачать р-ты в экселе. но они имеют странный вид
но формула высчита r-квадрата есть
В идеале конечно, чтобы эксель сам переберил соотношение зависимых и независимых переменных и выдавал списки тех моделей, где R-квадрат =0,5

Fsp050

Цитата:

для предсказания значения зависимой переменной через независимые

а есть список зависимых и список независимых под них. С функцией ЛИНЕЙН я знаком, но нужно понимать, какую переменную нужно предсказать и через какие.

andrewkard1980
в том то и дело. пусть эксель сам берет и перебирает. Задача этого перебора, чтоб он сам решил, какие модели лучшие. например, пусть начнет с переменной цели она будет зависимой. а независимой процесс. смотрим R-квадрат. далее добавляет вторую переменную,процесс, смотрим как изменился R квадрат, лишь бы не меньше 0,5 потом в список независимых переменных добавит третью переменную результат опять смотрит на Р-квадрат и так далее. там будет множество комбинаций моделей, тут 45 переменных и как минимум половина из которых плохие модели.
И потом ведь переменная цель может сама стать независимой, а переменная процесс зависимой. переменная цели может быть независимой и например для копинга дистанцирование и наоборот.

Fsp050

Цитата:

Задача этого перебора, чтоб он сам решил, какие модели лучшие.

А Вам то это зачем?

Добавлено:
Ладно, вопрос по алгоритму, берем первый столбик, sex, это y, второй sc, это х, высчитываем
R2, записываем результаты, потом для того же y, берем х: sc,    Цели, высчитываем
R2, записываем результаты, и так далее до "общее среднее", потом колонку sc - перемещаем на первое место, и это будет Y, и далее по этому же алгоритму. Правильно?



Добавлено:
Что то мне подсказывает, что это не совсем то что нужно, я так понял, Вам нужно знать с какими переменными R2 для конкретного Y будет максимальный, и это могут быть любые из представленных.