В A12 должно пойти 16 При следующем запуске в первую пустую ячейку после 16 в данном случае должна пойти цифра 34 И так далее до последнего значения в 4 колонке
Michael_S,
В A12 должно пойти 16 При следующем запуске в первую пустую ячейку после 16 в данном случае должна пойти цифра 34 И так далее до последнего значения в 4 колонкеant6729
Sub ttt() Dim Ar(), i&, Dic As Object, R& Set Dic = CreateObject("Scripting.Dictionary") R = Cells(Rows.Count, 1).End(xlUp).Row Ar = Range("A2:A" & R).Value For i = 1 To UBound(Ar) If Not Dic.exists(Ar(i, 1)) Then Dic.Add Key:=Ar(i, 1), Item:=Ar(i, 1) End If Next Ar = Range("D2", Cells(Rows.Count, 4).End(xlUp)).Value For i = 1 To UBound(Ar) If Not Dic.exists(Ar(i, 1)) Then Dic.Add Key:=Ar(i, 1), Item:=Ar(i, 1) Cells(R + 1, 1).Value = Ar(i, 1): R = R + 1 ' Exit For ' если эту строчку убрать - выведет все сразу; а так - один пуск, одно значение. End If Next
[/vba]
Один запуск - одно значение? или все сразу?
[vba]
Код
Sub ttt() Dim Ar(), i&, Dic As Object, R& Set Dic = CreateObject("Scripting.Dictionary") R = Cells(Rows.Count, 1).End(xlUp).Row Ar = Range("A2:A" & R).Value For i = 1 To UBound(Ar) If Not Dic.exists(Ar(i, 1)) Then Dic.Add Key:=Ar(i, 1), Item:=Ar(i, 1) End If Next Ar = Range("D2", Cells(Rows.Count, 4).End(xlUp)).Value For i = 1 To UBound(Ar) If Not Dic.exists(Ar(i, 1)) Then Dic.Add Key:=Ar(i, 1), Item:=Ar(i, 1) Cells(R + 1, 1).Value = Ar(i, 1): R = R + 1 ' Exit For ' если эту строчку убрать - выведет все сразу; а так - один пуск, одно значение. End If Next
Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents For Each c In Range("D3:D" & Cells(Rows.Count, 4).End(xlUp).Row) If c <> c.Offset(-1, 0) + 1 Then Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1) = c End If Next
[/vba]
вдруг тоже правильно [vba]
Код
Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents For Each c In Range("D3:D" & Cells(Rows.Count, 4).End(xlUp).Row) If c <> c.Offset(-1, 0) + 1 Then Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1) = c End If Next