Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 След.
Объединение больших csv-файлов в один с удалением заголовков, Общий объем объединенного файла порядка 1 Гб
 
Всем привет.
Есть очень быстро выполняющаяся процедура по объеднению csv-файлов в один. Файл в 1 Гб из 5 кусков по 200 Мб формируетя за 3-5 секунд.
Код
Sub JoinCSV()
    Dim pachb As String, path1 As String, path2 As String
    'pachb = Application.CurrentProject.Path
    pachb = "C:"
    path1 = pachb & "\Files\"
    path2 = pachb & "\OneFile\"
    Call Shell("cmd /c copy """ & path1 & "*.csv"" """ & path2 & "Joined.csv""")
End Sub
Для файлов без заголовков все проходит отлично. Их можно заготовить в отдельном файле и положить вместе с исходными csv-файлами.
Но если файлы содержат заголовки, то возникает проблема. Стандартные текстовые редакторы в некоторых случаях не позволяют даже открыть файл такого размера и удалить первую строку вручную.
Есть ли быстрый способ удаления первых строк в объемных тектовых файлах без применения циклов?

Заранее благодарен за подсказки.
Изменено: Дмитрий - 24.01.2017 20:33:48
Перевести картинку из бинарного вида (SQL Server) и сохранить в файл средствами VBA
 
Добрый день,
пытаюсь достать картинку из бинарного вида в SQL Server (база данных 1С 8.3) и сохранить в файл средствами VBA (Excel). Файл с картинкой создается, но, к сожалению, он не открывается ("... файл поврежден или слишком велик..." - размер файла вполне адекватен). Исходный код прилагаю ниже.
Код
Sub OpenADODB()
    Set cn = New ADODB.Connection
    cn.ConnectionString = "Provider=SQLOLEDB;Data Source=MVOLITTLE;" & _
                  "Initial Catalog=LittleHouseView;" & _
                  "User ID=логин;Password=пароль;"
    cn.Open
End Sub

Sub LoadPictureFromDB()
    Dim strStream As New ADODB.Stream
    Dim rs As ADODB.Recordset
    
    Call OpenADODB
    Set rs = New ADODB.Recordset
    
    With rs
        .ActiveConnection = cn
        .Open "select * from [dbo].[сКартинки] К where К.артикул = '48435';"
    End With
    
    Set strStream = New ADODB.Stream
    strStream.Type = adTypeBinary
    strStream.Open
    
    strStream.Write rs.Fields("Поле с картинкой").Value
    strStream.SaveToFile "C:\Temp\Temp.jpg", adSaveCreateOverWrite

End Sub
Нестандартное сравнение двух двухмерных диапазонов
 
Добрый день.
Помогите, пожалуйста, сравнить два двухмерных диапазона. В прикрепленном примере в столбце "Изменения в отделе" необходима формула, которая будет возращать ЛОЖЬ или ИСТИНА в зависимости от того, были ли изменения в столбце "Количество" по каждому из Отделов.
Например, по Отделу 1 есть 3 позиции. Если хоть по одной позиции Отдела 1 есть изменение в столбце "Количество", то весь Отдел 1 в столбце "Изменения в отделе" обозначается как ЛОЖЬ.

Заранее благодарен за помощь
Проблема со свойством ComboBox.RowSource после сохранения файла с расширением *.xlam (надстройка)
 
Всем привет.
Столкнулся с неожиданной проблемой. Свойство ComboBox.RowSource устанавливалось без проблем в обычном файле с расширением *.xlsx. Кусок кода привожу ниже.

cbPeriodTo.RowSource = shLists.Name & "!" & rgPeriod.Address

cbPeriodTo - это название комбо-бокс;
shLists - это переменная рабочего листа
rgPeriod  - это переменная диапазона

После того, как я сделал из этого файла надстройку, то на этом месте получаю ошибку: "Run-time error '380': Could not set the RowSource property. Invalid property value."
После возникновения этой ошибки меняю свойство рабочей книги IsAddin с True на False (книга отображается на панели задач) и опять все работает, переключаю назад на надстройку - опять не работает.

Сталкивался ли кто с такой проблемой? Как лечить?
Изменено: Дмитрий - 30.06.2015 14:24:34
Сравнение двух текстовых ячеек, Необходимо получить значение ИСТИНА
 
Добрый день,
маленький вопрос.
Есть две ячейки: А1 со значением "Самолет" и А2 со значением "Самолет белый". В ячейке А3 я пишу формулу "=A1&"*"=A2", которая возвращает ЛОЖЬ.
Вопрос. Как правильно прировнять две ячейки, чтоб получить ИСТИНА?

Заранее благодарен за подсказку.
Пользовательские функции (определение содержимого ячейки) в условном форматировании, Ограничение Excel: "Такой тип ссылки нельзя использовать в условном форматировании"
 
Всем добрый день.
Помогите, пожалуйста, советом.

Есть две пользовательских функции: HasFormula и HasLink. Ниже привожу коды.
Код
Function HasFormula(cell As Range) As Boolean
    HasFormula = cell.HasFormula
End Function

Function HasLink(cell As Range) As Boolean    
   With cell
        If .HasFormula Then
            If InStr(1, .Formula, "[") <> 0 And InStr(1, .Formula, "]") Then
                HasLink = True
            Else
                HasLink = False
            End If
        Else
            HasLink = False
        End If
    End With
    
End Function
 

Первая функция возвращает значение ИСТИНА, если ячейка содержит формулу, и ЛОЖЬ, - если не содержит. Вторая функция возвращает значение ИСТИНА, если ячейка содержит ссылку на другие книги, и ЛОЖЬ, - если не содержит.
Обе функции я планировал включить с свою пользоватеьскую надстройку и использовать в условном форматировании для заливки цветом соответствующих ячеек, но столкнулся с одной особенностю. Если эти функции включить в надстройку и попытаться применить в условном форматировании, то Excel выдает сообщение следующего содержания: "Такой тип ссылки нельзя использовать в условном форматировании". Если же эти функции скопировать непосредственно в ту книгу, где планируется использовать условное форматирование, то проблем не возникает.

Подскажите, можно ли как-то обойти это ограничение и использовать эти функии из надстройки, так как копировать их во все файлы - это огромное неудобство.

Заранее благодарен за ответ.
Возврат статуса на на конкретную дату, Формулы
 
Добрый день.
Помогите, пожалуйста, написать формулу.
Есть следующая таблица с обозначением статуса вопроса:

ОтДоСтатус
01.01.201401.04.2014Переговоры
01.05.201401.09.2014Согласование документов
01.10.201401.11.2014Подписание договора
01.12.2014Запуск
И есть таблица с конкретными датами:
Период01.01.201401.02.201401.03.201401.04.201401.05.201401.06.201401.07.201401.08.201401.09.201401.10.201401.11.201401.12.2014
Статус
Как во вторую таблицу в поле "Статус" подтянуть соответствующий статус из первой таблицы?
Пример прикреплен.

Заранее благодарен за помощь
Файл рекомендован для чтения. Можно ли убрать данное оповещение при открытии файла конкретным пользователем?, VBA
 
Добрый день.
Помогите, пожалуйста, советом. Есть один файл, в который все изменения вношу в основном я. Рекомендован он только для чтения, о чем выводится соответствующее уведомлении при открытии. Я хочу сделать так, чтобы при открытии файла мною это уведомление не выводилось. Пробовал делать так:
Код
Private Sub Workbook_Open()
    Sheets(1).Activate
    With Application
        If .UserName = "dmitriy_po" Then
            .DisplayAlerts = False
        End If
     End With
 End Sub 
Но это не помогает.
Может кто-то знает как реализовать?
Изменено: Дмитрий - 27.08.2014 00:28:37
Проблемы с открытием файла после его сохранения через VBA (GetSaveAsFileName, Workbook.SaveAs), VBA
 
Всем привет.
Помогите, пожалуйста, с сохранением кгниги в VBA. Использую функцию GetSaveAsFileName для выбора пути сохранения созданного файла с данными, загруженными из Access. После завершения процедуры предполагается закрытие файла с сохранением всех изменений.
Есть следующие проблемы:
1. Сохраненная книга с расширением *.xlsx не открывается. Пишет, что "... формат или расширение этого файла являются недопустимыми. Убедитесь, что файл не поврежден..." и т.д.
2. Если при сохранении файла выбрать расширение *.xls или изменить расширение уже сохраненного файла на *xls, то файл открывается, но с предварительным уведомлением, что "действительный формат файла отличается от указываемого его расширением имени файла. Перед открытием файла убедитесь... Открыть этот файл сейчас?".
3. Если же в коде "упразднить" закрытие файла и оставить файл открытым, то при его сохранении я получаю следующее уведомление: "Файл 'Такойто.xlsx' может содержать возможности, несовместимые с форматом 'SYLK (Symbolic Link)'. Сохранить книгу в этом формате?..."  и т.д.

Как решить данную проблему? Может я неправильно использую функцию GetSaveAsFileName? Ниже привожу выдержки из кода, относящиеся к сохранению файла.

Заранее благодарен за помощь.
Код
   Dim vPath As Variant
   Dim stSave As String
   Dim stFilter As String
   Dim bOpenReport As Boolean
   ...
   stFilter = "Книга Excel (*.xlsx), *.xlsx,Книга Excel 97-2003(*.xls),*.xls,Двоичная книга Excel(*.xlsb), "
   stFilter = stFilter + "*.xlsb,Книга Excel с поддержкой макросов (*.xlsm), *.xlsm"
   vPath = Application.GetSaveAsFilename("", stFilter, , "Saving Roaming Statistic Report for " & cbCountry.Value)
   ...
   
      stSaveAs = vPath   
   ...
    Application.SheetsInNewWorkbook = 1
    Set wrbReport = Workbooks.Add
   ...
    With wrbReport
      If stSaveAs <> "<no path specified>" Then
                  .SaveAs stSaveAs, xlLocalSessionChanges
               End If
              .Close SaveChanges:=True
           End If
    End With
Экспорт данных в Excel из Access. VBA, ошибка при исполнении кода
 
День добрый.
Помогите, пожалуйста, с ошибкой Run-time error '-2147467259 (80004005)': Method 'CopyFromRecordset' of object 'Range' failed.
Очень прошу помочь ибо уже начинаю отчаиваться в поисках проблемы. Написал код, который выполняет выгрузку данных из базы данных Access в Excel согласно выбранным пользователем параметрам. Заранее приношу извинения за то, что привожу достаточно объемный код, но это исключительно для полноты картины.
Аргументы в процедуру передаются из пользовательской формы, в частности: начальный период, конечный период и страна.
Фишка в том, что ошибка Run-time error '-2147467259 (80004005)' проявляется, когда я пытаюсь выгрузить информацию по конкретным странам (в данном случае Бразилия),
и макрос прерывается на выгрузке определенной записи, которая ничем особенным от других не отличается. То есть, частично работает.
В запросе длинных полей (свыше 255 символов), полей MEMO нет. Пытался изменить формулы вычислений, но не помогло.

Посмотрите, пожалуйста, кто-нибудь опытным взглядом и укажите где собака зарыта. Возможно кто-то подскажет обходные пути, ведь в самом Ассеssе запрос формируется нормально.

Заранее благодарен за подсказки.
Код
Sub RunCasePerCountry(Optional dPeriodFrom As Date = #7/1/2013#, Optional dPeriodTo As Date = #6/1/2014#, Optional stCountry As String = "Brazil", _
    Optional stCurrency As String = "EUR", Optional stSaveAs As String, Optional bOpenReport = True)
    
    Dim MyDatabase As DAO.Database
    Dim MyRecordset As DAO.Recordset
    Dim stPeriodFrom As String, stPeriodTo As String
    Dim MyQuery As String
    Dim i As Integer, c As Integer
    Dim wrbReport As Workbook
    Dim shtData As Worksheet, shtReport As Worksheet
    
    stPeriodFrom = Month(dPeriodFrom) & "/" & Day(dPeriodFrom) & "/" & Year(dPeriodFrom)
    stPeriodTo = Month(dPeriodTo) & "/" & Day(dPeriodTo) & "/" & Year(dPeriodTo)
    
    Application.ScreenUpdating = False
    
    MyQuery = "SELECT tDirection.DIR_NAME AS Direction, tPeriod.YEAR_ AS [Year], tPeriod.MTH_NUM AS [Month], tPeriod.PERIOD AS Period, tCountry.COUN_NAME AS Country, "
    MyQuery = MyQuery + "qUnionTrafficAll.TAP_CODE AS [TAP Code], qTAP_DP_Status.DP_NAME AS [Discount Partner], IIf([tDiscountStatus].[ST_NAME] Is Null,'No Discount',"
    MyQuery = MyQuery + "[tDiscountStatus].[ST_NAME]) AS Status, tTraffic_EDS.TRF_NAME AS Service, tPartner.PART_NAME AS Partner, qUnionTrafficAll.NUM_CED AS Traffic, "
    MyQuery = MyQuery + "[qUnionTrafficAll].[S_GR_CH]*[qSDRRates_" & stCurrency & "].[SDR_RATE] AS [Gross Charge], "
    MyQuery = MyQuery + "IIf([qDiscountTariffs_" & stCurrency & "].[IOT_DISC] Is Null,[Gross Charge],[qDiscountTariffs_" & stCurrency & "].[IOT_DISC]*[qUniontrafficAll].[NUM_CED]) AS [Net Charge], "
    MyQuery = MyQuery + "[Net Charge]/[qUniontrafficAll].[NUM_CED] AS [Actual Rate], qDiscountTariffs_" & stCurrency & ".IOT_DISC "
    MyQuery = MyQuery + "FROM (tCountry INNER JOIN tPartner ON tCountry.COUN_CODE = tPartner.COUNT_CODE) INNER JOIN (((tCallEventDetail INNER JOIN "
    MyQuery = MyQuery + "(((tPeriod INNER JOIN (((qUnionTrafficAll LEFT JOIN qDiscountTariffs_" & stCurrency & " ON (qUnionTrafficAll.DIR_CODE = qDiscountTariffs_" & stCurrency & ".DIR_CODE) AND "
    MyQuery = MyQuery + "(qUnionTrafficAll.YEAR_ = qDiscountTariffs_" & stCurrency & ".YEAR_) AND (qUnionTrafficAll.MTH_NUM = qDiscountTariffs_" & stCurrency & ".MTH_NUM) AND "
    MyQuery = MyQuery + "(qUnionTrafficAll.CED_CODE = qDiscountTariffs_EUR.CED_CODE) AND (qUnionTrafficAll.SF1_CODE = qDiscountTariffs_" & stCurrency & ".SF1_CODE) AND "
    MyQuery = MyQuery + "(qUnionTrafficAll.TAP_CODE = qDiscountTariffs_EUR.TAP_CODE)) LEFT JOIN qSDRRates_" & stCurrency & " ON (qUnionTrafficAll.YEAR_ = qSDRRates_" & stCurrency & ".YEAR_) AND "
    MyQuery = MyQuery + "(qUnionTrafficAll.MTH_NUM = qSDRRates_EUR.MTH_NUM)) INNER JOIN tServiceFamily1 ON qUnionTrafficAll.SF1_CODE = tServiceFamily1.SF1_CODE) ON "
    MyQuery = MyQuery + "(tPeriod.MTH_NUM = qUnionTrafficAll.MTH_NUM) AND (tPeriod.YEAR_ = qUnionTrafficAll.YEAR_)) INNER JOIN tDirection ON "
    MyQuery = MyQuery + "qUnionTrafficAll.DIR_CODE = tDirection.DIR_CODE) INNER JOIN tTAP ON qUnionTrafficAll.TAP_CODE = tTAP.TAP_CODE) ON tCallEventDetail.CED_CODE = "
    MyQuery = MyQuery + " qUnionTrafficAll.CED_CODE) LEFT JOIN qTAP_DP_Status ON (qUnionTrafficAll.TAP_CODE = qTAP_DP_Status.TAP_CODE) AND (qUnionTrafficAll.YEAR_ = qTAP_DP_Status.YEAR_) "
    MyQuery = MyQuery + "AND (qUnionTrafficAll.MTH_NUM = qTAP_DP_Status.MTH_NUM)) INNER JOIN tTraffic_EDS ON (tServiceFamily1.SF1_CODE = tTraffic_EDS.SF1_CODE) "
    MyQuery = MyQuery + "AND (tCallEventDetail.CED_CODE = tTraffic_EDS.CED_CODE)) ON tPartner.PART_CODE = tTAP.PART_CODE "
    MyQuery = MyQuery + "WHERE (((tPeriod.PERIOD) Between #" & stPeriodFrom & "# And #" & stPeriodTo & "#) AND ((tCountry.COUN_NAME)='" & stCountry & "'))"
    
    Set MyDatabase = DBEngine.OpenDatabase("\\palladium_zdm\data\NetStorage\Int_roam\Polishchuk\Roaming Partners Traffic Database\Roaming Statistic Database.mdb")
     
    Set MyRecordset = MyDatabase.OpenRecordset(MyQuery)
    
    Application.SheetsInNewWorkbook = 1
    Set wrbReport = Workbooks.Add
    
    With wrbReport
        Set shtData = .Sheets(1)
        shtData.Name = "Data"
        ThisWorkbook.Sheets("Model").Copy before:=shtData
        Set shtReport = .Sheets("Model")
        shtReport.Name = "Report"
    End With
    
    With shtData
        .Select
        .UsedRange.ClearContents  
     .Range("A2").CopyFromRecordset MyRecordset ' ОШИБКА ВОЗНИКАЕТ В ЭТОМ МЕСТЕ
        For i = 1 To MyRecordset.Fields.Count
            .Cells(1, i).Value = MyRecordset.Fields(i - 1).Name
        Next i
    End With    
    
    With wrbReport
        If stSaveAs <> "<no path specified>" Then
            .SaveAs stSaveAs
            If bOpenReport = False Then
                .Close
            End If
        End If
    End With
    
    MsgBox "Your Query has been Run"    
End Sub 
Изменено: Дмитрий - 22.07.2014 17:52:57
Странность в работе конструкции With... End With, VBA
 
Всем привет.
Помогите, пожалуйста.
У меня возникает одна странность в работе конструкции With... End With. Не смотря на то, что рабочая книга и лист четко определены (ThisWorkbook.Worksheets("Lists"  ;)  , макрос используем ячейки A2, B2 и C2 именно активного листа активной рабочей книги. Ниже прилагаю выдержку из кода:
Код
    With ThisWorkbook.Worksheets("Lists")
        Set rgCountry = .Range(.Range("A2"), .Range("A2").End(xlDown))
        Set rgCurrency = .Range(.Range("B2"), .Range("B2").End(xlDown))
        Set rgPeriod = .Range(.Range("C2"), .Range("C2").End(xlDown))
    End With 
Как вариант, пробовал использовать переменную:
Код
Set wbLists = ThisWorkbook.Worksheets("Lists")

With wbLists.Cells
        Set rgCountry = .Range(.Range("A2"), .Range("A2").End(xlDown))
        Set rgCurrency = .Range(.Range("B2"), .Range("B2").End(xlDown))
        Set rgPeriod = .Range(.Range("C2"), .Range("C2").End(xlDown))
    End With 
Пробовал даже так:
Код
Set wbLists = ThisWorkbook.Worksheets("Lists")

With wbLists.Cells
        Set rgCountry = .Range(.Range("A2"), .Range("A2").End(xlDown))
        Set rgCurrency = .Range(.Range("B2"), .Range("B2").End(xlDown))
        Set rgPeriod = .Range(.Range("C2"), .Range("C2").End(xlDown))
    End With 
Но все тщетно. Макрос все равно использует данные активного листа, а не указанного.

Укажите, пожалуйста, где упущение?
Заранее благодарен.
Изменено: Дмитрий - 16.07.2014 11:00:58
Перенос данных из Таблицы 1 в Таблицу 2 на основании значений нескольких столбцов
 
Добрый день.
Помогите, пожалуйста, перенести значения из столбца "Индикатор" таблицы 1 в одноименный столбец Таблицы 2. Не могу придумать формулу. Пример прикреплен.
Заранее благодарен.
Возможно ли изменить контекстное меню, вызываемое при автофильтре?, VBA
 
Хочу разработать дополнительные опции фильтрования и поместить их в контекстное меню автофильтра. Возможно ли изменить контекстное меню, вызываемое при автофильтре?
Закрашенные квадраты в контекстном меню вместо текста (как в "Фильтр по цвету")., VBA
 
Добрый день.
Возмтожно ли в контексное меню, вместо команды/операции, добавить прямоугольник(и) с заданным цветом (как при выборе функции "Фильтр по цвету" ;) ? Если можно, то поделитесь примерами, пожалуйста.

Заранее благодарен за ответ.
Изменено: Дмитрий - 10.02.2014 16:37:21
Извлечение уникальных значений из исходного диапазона и их вставка в указанное место, VBA. Не получаеться выбрать диапазон для вставки в другой книге c помощью InputBox
 
Добрый день, Уважаемые!
Написал небольшой макрос, который выбирает уникальные значения из выделенного диапазона и вставляет их в место, указанное с помощью функции InputBox  (код приведен ниже).
Есть один недостаток: InputBox не позволяет выбирать диапазон для вставки из другой рабочей книги. Я пытался решить это проблему с помощью формы с инструментом RefEdit (модальный режим), но тут также нельзя "прыгать" между книгами.

Вопрос номер 1. Есть способы, позволяющий выбирать диапазон для вставки из других рабочих книг (переключаться между книгами)?

Вопрос номер 2. Я хочу реализовать эту процедуру в немодальном режиме, то есть, чтобы при нажатии кнопки "Вставить" ("ОК" ) происходила вставка, НО... чтоб форма не исчезала, а позволяла работать с другими диапазонами (выделять другой исходный диапазон и выбирать другой диапазон для вставки). Это для тех, кто делает множество однотипных операций подряд (выделил - вставил, выделил - вставил). Пробовал использовать опять таки RefEdit в немодальном режиме, но он виснет почему-то.

Заранее благодарен за рекомендации.
Простыня удалена [МОДЕРАТОР]
Поиск и возврат данных по начальным символам, Формулы
 
Здравствуйте!
Помогите, пожалуйста, написать формулу, которая найдет в диапазоне и возвратит значение ячейки, в котором имеется соответствие по первым символам. Смотрите прилагаемый пример.

Заранее благодарен.
Возврат ячейки на пересечении столбца и строки, VBA. Метод Intersect.
 
Доброго дня!
Есть две произвольных ячейки.
Как используя метод Intersect получить ячейку, находящуюся на пересечении ряда одной ячейки и столбца второй ячейки?
У меня возвращается ошибка 1004.

Заранее благодарен за помощь.
Изменено: Дмитрий - 05.11.2013 18:24:15
Работа с коллекциями в VBA
 
Добрый день!
Есть два диапазона со значениями. Необходимо создать коллекцию, в которую выбрать "лишние" элементы из второго диапазона. Помогите, пожалуйста! Ниже привожу код, который не работает, а также прикрепляю сам пример.

Заранее благодарен.

Код
Sub Collections()
    Dim Names As New Collection
    Dim NamesNew As New Collection
    Dim NamesC3 As New Collection
    Dim NamesR1 As Range
    Dim NamesR2 As Range
    Dim cell As Range
        
    Set NamesR1 = ThisWorkbook.Sheets(1).Range("A1:A3")
    Set NamesR2 = ThisWorkbook.Sheets(1).Range("B1:B5")
        
    On Error Resume Next
    For Each cell In NamesR1
            Names.Add cell.Value, CStr(cell.Value)
    Next cell
    
    For Each cell In NamesR2
        Names.Add cell.Value, CStr(cell.Value)
        If Err.Number <> 457 Then
            NamesNew.Add cell.Value, CStr(cell.Value)
        End If
    Next cell
    On Error GoTo 0
    Debug.Print NamesNew.Count
    
End Sub
Изменено: Дмитрий Полищук - 01.11.2013 21:30:00
Суммирование по нескольким критериям и содержание раскрывающихся списков
 
Добрый день!
Подскажите, пожалуйста, по вопросам:
1) суммирования по нескольким критериям (возможность использования функции СУММЕСЛИМН вместо СУММПРОИЗВ)
2) формирования содержания раскрывающихся списков (проверка данных).

Все вопросы сформулированы в примечаниях в прикрепленном примере.
Заранее благодарен за помощь.
Как скопировать ссылку на лист в той же рабочей книге из одной ячеки в другую, VBA
 
Добрый день!
Помогите, пожалуйста.

Как в прилагаемом примере с помощью VBA скопировать ссылку из ячейки A1 листа Ссылка1 в ячейку А1 листа Ссылка 2.
Наличие сводной таблицы в файле определяет ошибку 1004, Очень странная ошибка. Помогите "утилизировать"
 
Добрый день!
Я создал функцию, проверяющую наличие необходимых заголовков в файле со статистикой. В результате функция возвращает или название листа с заданными заголовками, или False, если все искомые заголовки не обнаружены.
В процессе наткнулся на ошибку, над которой долго ломал и голову и нервы. Долго не мог понять в чем-же дело. Как оказалось, ошибка была вызвана наличием сводной таблицы в файле.
Не могу понять каким образом наличие сводной таблицы влияет на корректное выполнение макроса.

Помогите, пожалуйста, разобраться. Конечно можно переписать функцию по-другому, но, т.к. убил кучу времени перед тем как удалить сводную таблицу, то хочу разобраться в чем проблема именно ЗДЕСЬ и как ее решить именно ЗДЕСЬ в этом коде!На будущее пригодится.

Файл с макросом прикреплен (сводная таблица содержится на листе 7). Дополнительно код приведен ниже.

Буду очень благодарен за вашу помощь.

Код
Sub Test()
    Dim Attr()
    Dim Dr As String
    Dim sht As Object
    Dim tr As Integer, i As Integer
    Dim cell As Range
    Dim AttrRow As Range
    Dim Statfile As Workbook
    
    Set Statfile = ThisWorkbook
    
    ReDim Attr(1 To 8)
    Attr(1) = "Call Event Detail"
    Attr(2) = "Year-Month"
    Attr(3) = "Service Family"
    Attr(4) = "Connected Partner TAP Code"
    Attr(5) = "Settlement GrossCharge"
    Attr(6) = "Chargeable Minutes"
    Attr(7) = "Chargeable Megabytes"
    Attr(8) = "Number of CallEventDetails"
    
    MsgBox CheckFileNew(Statfile, Attr)
    
End Sub

Function CheckFileNew(File As Workbook, Attr() As Variant) As Variant
    Dim AttrRow As Range
    Dim cell As Range
    Dim i As Integer
    Dim sht As Object
    
    For Each sht In File.Sheets
        If TypeName(sht) = "Worksheet" Then
           For i = 1 To UBound(Attr)
                With sht
                    If AttrRow Is Nothing Then
                        Set AttrRow = .Cells.find(What:=Attr(i), After:=.Cells(1), LookIn:=xlValues, LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                            False, SearchFormat:=False)
                    Else
                        On Error Resume Next
                        Set cell = .Cells.find(What:=Attr(i), After:=Cells(1), LookIn:=xlValues, LookAt:=xlWhole, _
                                SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                                False, SearchFormat:=False)
                        On Error GoTo 0
                        If Not cell Is Nothing Then
                            Set AttrRow = Union(AttrRow, cell)
                        End If
                    End If
                End With
            Next i
         End If
      If Not AttrRow Is Nothing Then
            If AttrRow.Cells.Count = UBound(Attr) And AttrRow.Rows.Count = 1 Then
                CheckFileNew = sht.Name
                Exit For
            End If
       Else
            CheckFileNew = False
       End If
    Next sht
    
End Function
Изменено: Дмитрий Полищук - 23.10.2013 00:20:45
Как сделать активной только что созданную в VBA книгу?, Workbooks.Add
 
Добрый день!
Подскажите, пожалуйста, как после использование метода Workbooks.Add сделать так, чтобы созданная книга стала активной (отображалась поверх остальных окон).

Заранее благодарен.
Выбор уникальных значений из диапазона и вставка их в указанную ячейку, VBA
 
Добрый день!
Подскажите, пожалуйста, что не так в прилагаемой процедуре? Коллекция из уникальных значений формируется правильно, массив из тех же значений - тоже правильно, но при вставке я получаю только первый элемент массива в каждой ячейке. При вставке я избегал цикла, как рекомендует Уокенбах, но у него в примере данные из массива в диапазон переносятся правильно, а у меня нет.

Буду благодарен за помощь.

Код
Sub CopyPasteUnique()
 'процедура формируем массив уникальных значений в выбранном диапазоне и вставляем его в указанную ячейку
    Dim cell As Range
    Dim Unique As New Collection
    Dim cellPaste As Range
    Dim i As Long
    Dim UniqueArray()
           
    If TypeName(Selection) <> "Range" Then
        Exit Sub
    End If
           
    On Error Resume Next
'запрашиваем у пользователя ячейку для вставки
    Set cellPaste = Application.InputBox("Укажите ячейку для вставки", Type:=8)
    On Error GoTo 0
        If cellPaste Is Nothing Then
            Exit Sub
        End If
    Set cellPaste = cellPaste.Range("A1")
    On Error Resume Next
    For Each cell In Selection
   'формируем коллекцию из уникальных значений диапазона
        If cell.Value <> "" Then
            Unique.Add cell.Value, CStr(cell.Value)
        End If
    Next cell
    On Error GoTo 0
    
    ReDim UniqueArray(1 To Unique.Count)
   'переносим уникальные значения в массив
        For i = 1 To Unique.Count
            UniqueArray(i) = Unique.Item(i)
        Next i    
'определяем диапазон для вставки
    Set cellPaste = Range(cellPaste, cellPaste.Offset(Unique.Count - 1, 0))
   'вставляем массив в диапазон
' при вставке я пытался избежать цыкла (рекомендация одного автора учебника по VBA с примером).
' во всем диапазоне для вставки я получаю только первое значание массива
        cellPaste.Value = UniqueArray
    
End Sub
Процедура обработки события, генерируемое переименованием рабочего листа, VBA
 
Здравствуйте!
Возможно ли создать процедуру обработки события, которое генерируется переименованием рабочего листа? Что это за событие? Хочу сделать так, чтобы названия рабочих листов в книге соответствовало определенному шаблону, и чтобы данная процедура проверяла "правильность" переименования.

Заранее благодарен за ответ.
Сохранение значений переменных определенных в другой процедуре
 
Добрый день!

Подскажите, пожалуйста, новичку в VBA как можно сохранить значение переменной x из процедуры Calc. В процеждуре General я хочу получить x=3 расчитанной в процедуре Calc, но мне возвращается 0. Что я не так делаю? Как можно получить последние значения переменніх из других процедур?

Заранее благодарен за ответ.
Код
Sub General()
   Sub General()
    Dim Value As Double
    Dim x As Double
    Value = 2
    Call Calc(Value)
    MsgBox Value
    MsgBox x
End Sub


Sub Calc(Value)
    Static x As Double
    x = Value + 1
    Value = Value * 2
    
End Sub
Изменено: Дмитрий Полищук - 20.08.2013 17:19:06
Использование FileDialog(msoFileDialogFilePicker)
 
Привет всем!
Подскажите, пожалуйста, что не так делаю. Пытаюсь написать процедуру выбора файла рабочей книги через диалоговое окно для последующей работы с ним (в данном случае MsgBox с указание пути к файлу). При этом, если пользователь выбирает файл, отличающийся от шаблонов "*.xlsx", "*.xls" и "*.xlsm", то процедура возвращает пользовательское сообщение об ошибке. Но что-то не получается: либо ошибка для любых файлов, либо MsgBox с указанием пути для любых файлов.

Буду благодарен за подсказку.

Код
Sub PickFolder()
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    Dim vrtSelectedItem As Variant
    Dim MyCheck As Boolean
 
    With fd
       If .Show = -1 Then
          For Each vrtSelectedItem In .SelectedItems
             Select Case False
                Case MyCheck = vrtSelectedItem Like "*.xlsx", _
                   MyCheck = vrtSelectedItem Like "*.xls"
                   MyCheck = vrtSelectedItem Like "*.xlsm" 
                  MsgBox "Неверный формат"
                   Exit Sub
             Case Else
                   MsgBox "Путь к файлу: " & vrtSelectedItem
 
             End Select
            Next vrtSelectedItem
          Else
       End If
    End With
 
End Sub
Изменено: Дмитрий Полищук - 06.08.2013 12:47:44
Обновление сводного отчета на основе отчета со статистикой, Использование суммирование по двум и более условиям в VBA
 
Здравствуйте все!
Наведите, пожалуйста, на путь истинный. К посту прикреплено 2 файла "Сводный очет" и "Статистика". В начале каждого месяца я выгружаю файл статистики за прошедшие периоды (прошлый месяц и несколько предыдущих периодов). Данный файл со статистикой я использую для ежемесячного обновления сводного отчета. Пусть вас не смущает некоторая нескладность содержания отчетов. Это лишь пример, а столы, стулья и табуретки - это первое, что пришло мне в голову. На данный момент обновление статистики это полностью ручной процесс, который осуществляется с помощью построеня сводных таблиц по каждому товару плюс одна сводная таблица по платежам в разрезе каждого товара с последующим применение функции ВПР.
Я же решил полность автоматизировать этот процесс средствами VBA, в котором являюсь новичком.

Для информации, на самом деле контрагентов существует более 400, по каждому контрагенту 14 параметров для обновления (в примере -  8) , а файлы со статистикой содержат от 10.000 до 20.000 строк.

Порекомендуйте, пожалуйста, на основе прикрепленных примеров, каким образом в VBA наиболее эффективно осуществлять суммирование с одним и более условиями (период+контрагент+товар и т.д.)., а также, учитывая количество строки параметров для обновления, как сделать макрос максимально быстрым.

Заранее благодарен за советы.
Изменено: Дмитрий Полищук - 06.08.2013 00:42:55
Функция API GetWindowsDirectoryA
 
Доброго времени суток!
Помогите, пожалуйста, разобраться в одном примере функции API, вызываемую с помощью VBA, в котором я абсолютный чайник. Начал самообучатся несколько недель назад по Уокенбаху. Стараюсь вникнуть в каждый приводимый пример. Но вот этот понять не могу (возвращает название папки, в которой установлена операционная система Windows).
Код
#If VBA7 And Win64 Then
 Declare PtrSafe Function GetWindowsDirectoryA Lib "kernel32" _
 (ByVal lpBuffer As String, ByVal nSize As Long) As Long
#Else
 Declare Function GetWindowsDirectoryA Lib "kernel32" _
 (ByVal lpBuffer As String, ByVal nSize As Long) As Long
#End If

Sub ShowWindowsDir()
 Dim WinPath As String * 255
 Dim WinDir As String
 WinPath = Space(255)
 WinDir = Left(WinPath, GetWindowsDirectoryA _
 (WinPath, Len(WinPath)))
 MsgBox WinDir, vbInformation, "Windows Directory"
End Sub

Если конкретно, то:
1. Dim WinPath As String * 255 - зачем при объявлении переменной применять умножение на 255?
2. WinPath = Space(255) - 255 пробелов???
3. WinDir = Left(WinPath, GetWindowsDirectoryA (WinPath, Len(WinPath))) - из 255 пробелов мы возвращаем первых 10? [ Msgbox GetWindowsDirectoryA (WinPath, Len(WinPath)) возвращает значене 10].

Кто знаком с данным примером, объясните, пожалуйста, логику начинающему.Собственно пример из книги прикреплен.
Заранее благодарен.
Записанный максрос автофильтра не работает на защищенном листе
 
Доброго времени суток всем.
Помогите, пожалуйста
Записал следующий макрос на установку автофильтра при нажатии кнопки:
Код
Sub Макрос1()
' Кнопка_Щелчек
 ActiveSheet.Range("$B$17:$W$60"  ;)  .AutoFilter Field:=1, Criteria1:="=?????", _
 Operator:=xlAnd
End Sub

Проблема в том, что на защищенном листе этот макрос не работает (даже не смотря на разрешение на использование автофильтра).
Защитить лист мне необходимо, так как предполагается использование этого листа множеством пользователей. Как можно решить эту проблему?

Заранее благодарен за решение.
Изменено: Дмитрий Полищук - 11.07.2013 18:10:04
Формула для расчета суммы в зависимости от нескольких параметров
 
Помогите, пожалуйста, составить формулу для расчета суммы в зависимости от нескольких выбираемых условий:
- фирма (выбор названия фирмы из перечня);
- показатель (выбор доходов или расходов);
- период (выбор параметров "От" и "До).

Пример прикреплен. Для формулы предусмотрена ячейка с желтой заливкой.

Заранее благодарен за помощь.
Страницы: 1 2 След.
Наверх