Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 24.11.2018, 17:44   #11
dwmair23
Пользователь
 
Регистрация: 22.11.2018
Сообщений: 13
По умолчанию

Спасибо огромное за помощь.
dwmair23 вне форума Ответить с цитированием
Старый 30.11.2018, 09:06   #12
bothke
Пользователь
 
Регистрация: 26.05.2018
Сообщений: 18
По умолчанию

Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
1. Добавить в конец столба А листа Основной, с листов НовыйЛист1..N те позиции которых еще нету в столбце А.
2. прописать ВПР/СУММЕСЛИ для поиска значений из каждого листа.

Ваших навыков программирования хватит чтобы организовать 3 цикла для поиска "нового" наименования?
Код:
Цикл1: НовыйЛист1..НовыйЛистN
   Цикл2: От Строка3 до СтрокаПоследняя НовыйЛистХ
      Цикл3: От Строка3 до СтрокаПоследняя ОсновнойЛист
upd
или другой вариант поиска "новых" наименований
Код:
Option Explicit

Sub geee()
    Dim d As Object
    Dim i As Integer
    Dim sh As Integer
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets(1)
        i = 3
        Do While .Cells(i, "A") <> ""
            If Not d.Exists(.Cells(i, "A")) Then
                d.Add Trim(.Cells(i, "A")), Trim(.Cells(i, "A"))
            End If
            i = i + 1
        Loop
    End With

    Dim r As Integer: r = i + 1
    For sh = 2 To Sheets.Count
        With Sheets(sh)
            i = 3
            Do While .Cells(i, "A") <> ""
                If Not d.Exists(Trim(.Cells(i, "A"))) Then
                    d.Add Trim(.Cells(i, "A")), Trim(.Cells(i, "A"))
                    Sheets(1).Cells(r, "A") = Trim(.Cells(i, "A")): r = r + 1
                End If
                i = i + 1
            Loop
        End With
    Next
End Sub

а если так не получается? есть еще какой-то вариант?
Продвижение сайтов - cropas
bothke вне форума Ответить с цитированием
Старый 07.02.2019, 10:20   #13
dwmair23
Пользователь
 
Регистрация: 22.11.2018
Сообщений: 13
По умолчанию

Код:
.Value = WorksheetFunction.Transpose(di.keys)
на данной строчке возникает ошибка, если длина строки более 255 символов.

Возможно ли обойти данное ограничение?

Последний раз редактировалось dwmair23; 07.02.2019 в 16:56.
dwmair23 вне форума Ответить с цитированием
Старый 07.02.2019, 10:21   #14
dwmair23
Пользователь
 
Регистрация: 22.11.2018
Сообщений: 13
По умолчанию

У самого метода "WorksheetFunction.Transpose" есть ограничения я так понимаю.
dwmair23 вне форума Ответить с цитированием
Старый 07.02.2019, 10:23   #15
dwmair23
Пользователь
 
Регистрация: 22.11.2018
Сообщений: 13
По умолчанию

Вроде как можно избежать ограничений, если использовать пользовательскую функцию "TransposeArray":

Код:
Sub ПримерИспользования()
 ИсходныйМассив = ActiveSheet.UsedRange.Offset(1).Value
 ТранспонированныйМассив = TransposeArray(ИсходныйМассив)
End Sub
Вот код самой функции:

Код:
Function TransposeArray(ByVal arr As Variant) As Variant
     ' Пользовательская функция для транспонирования массива
    Dim tempArray As Variant
     ReDim tempArray(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
     For X = LBound(arr, 2) To UBound(arr, 2)
         For Y = LBound(arr, 1) To UBound(arr, 1)
             tempArray(X, Y) = arr(Y, X)
         Next Y
     Next X
     TransposeArray = tempArray
End Function

Последний раз редактировалось dwmair23; 07.02.2019 в 16:56.
dwmair23 вне форума Ответить с цитированием
Старый 07.02.2019, 10:25   #16
dwmair23
Пользователь
 
Регистрация: 22.11.2018
Сообщений: 13
По умолчанию

Теперь собственно вопрос - как функцию "TransposeArray" внедрить в такой вот код?

Код:
Option Explicit

Sub Dw()
Dim di As Object, i&, j&, x
Dim lCol As Long
Dim n1 As Variant
    
  Set di = CreateObject("scripting.dictionary")
  di.comparemode = vbTextCompare
  Range("C:Z").ClearContents
  For i = 2 To Worksheets.Count
    With Worksheets(i)
      Worksheets(1).Cells(2, i + 1) = .Name
      For Each x In .Range("B2", .Cells(.Rows.Count, 2).End(xlUp)).Value2
        di(x) = 0
      Next
    End With
  Next
  j = Cells(Rows.Count, 1).End(xlUp).Row
  For Each x In Range("A3:A" & j).Value2
    If di.exists(x) Then di.Remove x
  Next
  If di.Count Then
    With Cells(j + 1, 1).Resize(di.Count)
      .Value = WorksheetFunction.Transpose(di.keys)
      .Font.Color = vbRed
    End With
  Else
    MsgBox "Новых наименований нет", vbInformation
  End If
  Range("C3").Resize(j - 2 + di.Count, i - 2).Formula = _
    "=IFERROR(VLOOKUP($A3,INDIRECT(""'""&C$2&""'!B:C""),2,),""-"")"
    
 lCol = Worksheets(1).Cells(2, Columns.Count).End(xlToLeft).Column
 Worksheets(1).Cells(2, lCol + 1) = "Âñåãî"
 Worksheets(1).Cells(2, lCol + 2) = "Ðåçóëüòàò"
 
' n1 = Split(Cells(1, lCol).Address, "$")(1)
' MsgBox ("Последний столбец: " & n1 & lCol), vbInformation
 
 Cells(3, lCol + 1).Resize(j - 2 + di.Count, 1).FormulaR1C1 = "=SUM(RC3:RC[-1])"
 Cells(3, lCol + 2).Resize(j - 2 + di.Count, 1).FormulaR1C1 = "=rc[-1]-rc2"
 
End Sub

Последний раз редактировалось dwmair23; 07.02.2019 в 16:59.
dwmair23 вне форума Ответить с цитированием
Старый 07.02.2019, 11:28   #17
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Какой вариант пробовали?
Код:
.Value = TransposeArray(di.keys )
или
Код:
.Value = TransposeArray(di.keys ).value
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 07.02.2019, 11:52   #18
dwmair23
Пользователь
 
Регистрация: 22.11.2018
Сообщений: 13
По умолчанию

По всяко-разному пробовал.

Последний раз редактировалось dwmair23; 07.02.2019 в 17:59.
dwmair23 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Взятие определенных данных с других листов в таблицу на первом листе. Merelins Microsoft Office Excel 3 30.08.2013 15:25
Поиск значений на листе. Нужно оптимизировать Alex+ Microsoft Office Excel 3 30.08.2012 10:03
Сбор данных из нескольких листов на один с удалением дубликатов, но суммированием значений strannick Microsoft Office Excel 4 10.04.2012 19:18
Сравнение нескольких листов и перенос значений r-r Microsoft Office Excel 1 06.10.2011 11:46
отражение на листе значений из других листов alexarorel Microsoft Office Excel 1 20.04.2011 20:23