В таких случаях, если есть зуд использовать именно циклы (никогда не понимал, почему к ним такая тяга: один из самых неэффективных способов), то хоть применяйте ж функции Find / FindNext. Но тоже самое можно сделать одним выстрелом через ADO/XML, а говоря просто - с помощью SQL запросов, т.е. примитивных и старых SELECT/FROM/WHERE.

" ...ты видел хоть один код без использования цикла? может ты путаешь с goto?
а как ты собераешься с Find/FindNext перебирать 2 колонку с уникальными данными?
да и напомни пожалуйста, чего то я забыл, как/куда можно написать запрос для данного топика в проекте ВБА для активной книги?
может мы ненароком ошиблись форумом? :)..."

Привет, москоу!

Отвечаю по порядку. Да, видел. Более того, ты его тоже сейчас увидишь. Циклы и goto я не путаю с 1976 года, с тех пор, как я с ними познакомился. Перебор с Find ты можешь найти в моих примерах на форуме Relib.com. И, наконец, напоминаю забывчивым, куда можно написать SQL запрос в проекте ВБА для активной книги: в модуль, в класс модуль, в лист, в форму.

А теперь смотри, как его писать на примере модуля.

1. В листе Sheet1 в колонку А впиши все числа от 1 до 10. В колонку В впиши все нечетные числа от 1 до 19. Заполненный таким образом ранг назови Table.

2. На этот лист посади кнопку. Для этого листа скопируй этот код:

Option Explicit

Private Sub CommandButton1_Click()
DumpResults "D", "Sheet1", "F1", "F2", "C:\Temp\Table.XML"
DumpResults "E", "Sheet1", "F2", "F1", "C:\Temp\Table.XML"
End Sub

Private Sub DumpResults(ByVal pstrOutputRangeAddress As String, _
ByVal pstrOutputWshtName As String, _
ByVal pstrFieldOne As String, _
ByVal pstrFieldTwo As String, _
ByVal pstrFileXML As String)

Dim strSQL As String
Dim strFileXML As String

ThisWorkbook.Worksheets(pstrOutputWshtName).Range(pstrOutputRangeAddress & "1:" & pstrOutputRangeAddress & "65536").Clear

strSQL = "SELECT A." & pstrFieldOne & " FROM [Table] A WHERE NOT EXISTS (SELECT B." & pstrFieldTwo & " FROM [Table] B WHERE B." & pstrFieldTwo & " = A." & pstrFieldOne & ")"
strFileXML = "C:\Temp\Table.XML"
BuildMyXMLRecordset strSQL, strFileXML
ReadMyXMLData pstrOutputWshtName, pstrOutputRangeAddress & "1", strFileXML

End Sub

3. Создай модуль и в него скопируй этот код:

Option Explicit

Sub BuildMyXMLRecordset(ByVal pstrSQL As String, ByVal pstrFileXML As String)
Dim objMyRcrdst As ADODB.Recordset
Dim objMyStream As ADODB.Stream
Dim strCnctn As String

strCnctn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"

Set objMyRcrdst = New ADODB.Recordset
Set objMyStream = New ADODB.Stream

With objMyRcrdst

.CursorLocation = adUseClient
.Open pstrSQL, strCnctn, adOpenStatic, adLockReadOnly, adCmdText
.Save objMyStream, adPersistXML
.Close
With objMyStream
.SaveToFile pstrFileXML, adSaveCreateOverWrite
.Close
End With
End With

Set objMyStream = Nothing
Set objMyRcrdst = Nothing

End Sub

Sub ReadMyXMLData(ByVal pstrWsht As String, ByVal pstrRangeAddress As String, ByVal pstrFileXML As String)
Dim objMyRcrdst As ADODB.Recordset
Dim strCnctn As String

Set objMyRcrdst = New ADODB.Recordset

strCnctn = "Provider=MSPersist;"

With objMyRcrdst
.CursorLocation = adUseClient
.Open pstrFileXML, strCnctn, adOpenStatic, adLockReadOnly, adCmdFile
Set .ActiveConnection = Nothing
End With

With ThisWorkbook.Worksheets(pstrWsht)
.Range(pstrRangeAddress).CopyFromRecordset objMyRcrdst
End With

objMyRcrdst.Close
ThisWorkbook.Worksheets(pstrWsht).Activate

Set objMyRcrdst = Nothing

End Sub

4. Кликни кнопку. В две колонке выйдут уникальные для первого и уникальные для второго значения полей ранга Table.

Успехов, москоу!

Привет, Дадахан!

XML создан в частности и для таких вот вещей. Это совсем не извращение, этот подход взят мною из источников Microsoft, в которых он предлагался для решения задач вроде обсуждаемой здесь. Поэтому и я его предлагаю. Циклы как раз и есть мамонтово решение (ничего личного, ничего личного!) : из-за способа доисторического (перебор по одному, да безындексный!). Мое решение - очень простое, код то уже припасен, и я его за считанные минуты адаптировал, главным образом переписав сам запрос. Вы посмотрите: он же очень мал, но при этом гибок. И преимущество его очевидно на больших массивах данных. Вскоре вот новый Excel Microsoft обещает - до миллиона что-ли строк на листе. Так циклами там перебирать и перебирать. Тем мой пример и симпатичнее: на больших массивах его код гораздо быстрее. Но я ваш код не ругаю: он же работает. В конце концов, как говорят у нас в Коннектикуте, кота можно ободрать разными способами.

Так что не брезгуйте, пользуйте новые технологии, тем более, что вот он пример мой: берите его, он удобен, сколько раз спасал и меня и многих других форумчан. Да, данный пример и есть хоть маленький, но проект, не кусок.

Успехов

vladconn

Дадахан, Find/FindNext подразумевает циклы! Я об этом и писал, что если циклы, то тогда хорошо с Find/FindNext (или что-то одно из них по потребности). Никто и не советовал от них совершенно отказываться.

У меня ощущение, что вместо диалога по сути, все вращается вокруг некоего ущемленного самолюбия. Хорошо, если будет время, я попробую сам найти.

А касательно миллиона строк - что-то слишком обидчиво вы среагировали, что бы вы не сказали. Очень чувствуется. Ну попробуйте для начала на 60,000 строках. Но миллион - не за горами. Я бы смотрел вперед, а не в 1976 год. Да, если мой первый пост был воспринят как упрек, то я прошу прощения, я не желал вас или кого-то упрекать.

Успехов

vladconn

Вот, кстати, совсем простой пример без всяких циклов как раз для Марии Кондратович. Он подразумевает заполненными до десятой строки колонки А и В:

Private Sub CommandButton1_Click()
FindDiffs 10, "Sheet1"
End Sub


Private Sub FindDiffs(ByVal plngLastRow As Long, ByVal pstrWsht As String)
Dim objRange As Range

Set objRange = ThisWorkbook.Worksheets(pstrWsht).Range("C1:C" & CStr(plngLastRow))

With objRange
.FormulaArray = "=IF(RC[-2]:R[" & CStr(plngLastRow - 1) & "]C[-2]=RC[-1]:R[" & CStr(plngLastRow - 1) & "]C[-1],1,"""")"
End With

End Sub

Так что тут нет ни циклов, ни Find/FindNext, ни XML. И волки сыты, и овцы целы.

:о)))

vladconn

Дадахан,

Спасибо за комплимент.

Единственная маленькая поправка: это ваш метод сильно тормозит систему на 60,000 строках, а мой метод исполняется практически мгновенно. У меня: за 0.31 сек, а цикл ваш: за черт знает сколько (жду уже минуту, Excel не реагирует, черт, связался таки с вашим кодом, ведь знал). Вот: прождал 5 минут и прервал. Да, я взял ваш код как есть. Он к тому же еще был и с ошибкой! Ну и ну!

Да, а прямое же заполнение единицами взяло больше 9 секунд.

:0))

О, прелесть. Вот этот ваш "код"

sub CheckThis()
for i=acitvecell.row to 10000
if cells(i,2).value="" then exit for
for t=activecell.row to 10000
if cells(t,2).value="" then exit for
if cells(t,1).value=cells(i,2).value then cells(t,3).value=1
next t
next i end sub

таки не работает. Так что я беру свои слова обратно о том, что ваш код якобы работает. Или вы имели ввиду какой-то другой код? Мол публикую одно, а в голове держу другое?

:0)))

Мне уже есть чем заняться. Да и сколько можно бисер-то метать.

[quot Magnus23]Хватит господа. На личности переходить не нужно. Думаю Марии кондратович уже достаточно материала для решения проблемы и дабы упредить возможные негативные последствия, я топик закрою.[quot]

Наконец, Magnus23! У вас тут картинка не видна что-то. Но на личности мы и не переходим. Я вот и на "вы" почти сразу стал обращаться, и извинялся, правда без взаимности. Бисер, одним словом. Ну код не лучший был представлен, обидно, я понимаю, чего уж. У меня у самого такое бывало не раз. В конце-концов я же дал два эффективно работающих примера. Так что вы правильно сказали, материала достаточно.

:о )))