Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Сбор данных из разных видов файлов
 
Друзья, привет.

Делаю форму автообновления отчета. Необходимо собрать из файла с определенного лист информацию.
Столкнулся с несколькими проблемами:
1) Необходимо проверить какой из 2х возможных названий листов используется в открытой таблице. Реализую через функцию проверки, но что то ошибка типов.
На строке CheckList = CheckListSub(NameFile) - выдает ошибку типов "ByRef argument type mismatch"

Код
' This book a have list?
Function SheetExists(SheetName As String) As Boolean
On Error Resume Next
SheetExists = Not Sheets(SheetName) Is Nothing
End Function

' Chek on Name List
Function CheckListSub(SheetName As String) As String
Dim wb As Workbook
Set wb = SheetName

CountList = 0

If SheetExists("Data") Then
    Set CheckList = wb.Worksheets("Data")
    CountList = CountList + 1
End If

If SheetExists("Динамика KPIs") Then
    Set CheckList = wb.Worksheets("Динамика KPIs")
    CountList = CountList + 1
End If

If CountList = 0 Then
MsgBox "Оба листа отсутствуют"
CheckList = "Error"
End If
If CountList = 2 Then
MsgBox "Оба листа присутствуют"
CheckList = "Error"
End If

End Function

Sub GoData()
     Application.Calculation = xlCalculationManual
     avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", 1, "Âûáåðèòå îò÷åò ", , False)

    If VarType(avFiles) = vbBoolean Then
        'áûëà íàæàòà êíîïêà îòìåíû - âûõîä èç ïðîöåäóðû
        MsgBox "Íå âûáðàí èñòî÷íèê äàííûõ"
        Exit Sub
    End If
    
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False

i = InStrRev(avFiles, "\") 
NameFile = """ & Mid(avFiles, i + 1) & """

Workbooks.Open Filename:=avFiles

Set Database = ActiveWorkbook
CheckList = CheckListSub(NameFile)

ActiveWindow.Close False

        Calculate
        Application.Calculation = xlAutomatic
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True

End Sub
2) Нужно как то отметить цветом необходимые столбцы (в примере зеленым) и удалить все не отмеченные (красным).
Пока вообще не придумал как это сделать. У всех необходимых столбцов есть общее XQXX (X) (прим: Q3'18 (F) )

Комрады есть идеи, опыт, предложения?

Спасибо
 
Цитата
phelex написал:
Комрады есть идеи, опыт, предложения?
Для начала научитесь всегда объявлять переменные, да что бы типы при передаче в функцию совпадали.
Установите в опциях что бы в каждом модуле первой строкой было написано Option Explicit это поможет избежать многих проблем.
Изменено: Nordheim - 14 Май 2019 13:55:40
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, спасибо.
Считаете проблема что переменная не определена?
 
Цитата
phelex написал:
Считаете проблема что переменная не определена?
В данном случае типы передаваемых данных не совпадают, у вас в тексте ошибки об этом написано.
"Все гениальное просто, а все простое гениально!!!"
 
К сожалению не понимаю как решить проблему. Есть возможность предложить код с исправлением?

Спасибо
 
После этой строки:
Код
Sub GoData()
запишите:
Код
Dim NameFile As String
Но вообще лучше всегда использовать Option Explicit - избежите множество ошибок в будущем: Variable not defined или что такое Option Explicit и зачем оно нужно?

А эту строку:
Код
NameFile = """ & Mid(avFiles, i + 1) & """
можно записать без кавычек - зачем они? У Вас книги тоже с кавычками записаны?
Код
NameFile = Mid(avFiles, i + 1)
Да и вообще, функция написана коряво и работать не будет. Хотя бы это:
Код
Set wb = SheetName
нельзя объекту назначить тип String. Надо как минимум:
Код
Set wb = Application.Workbooks(SheetName)
хотя проще сразу передавать в качестве аргумента именно ссылку на книгу, а не её имя. Т.е. вместо этих строк:
Код
Function CheckListSub(SheetName As String) As String
Dim wb As Workbook
Set wb = SheetName
записать
Код
Function CheckListSub(wb As Workbook) As String
а функцию вызывать так:
Код
Workbooks.Open Filename:=avFiles 
Set Database = ActiveWorkbook
CheckList = CheckListSub(Database)
Изменено: Дмитрий(The_Prist) Щербаков - 16 Май 2019 12:01:18
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Что то не помогает.

Вот обновленный код, типы прописаны.
По факту он должен открывать указанную книгу, определять какой из двух листов есть.
И копировать все информацию в книгу-носитель скрипта.
Сейчас не получается пройти этап определения наличия листа т.к. путь к файлу не является как бы книгой...
Просьба шарящих посмотреть свежим взглядом, возможно подскажите в чем ошибка

Код
Option Explicit
Function SheetExists(SheetName As String) As Boolean
On Error Resume Next
SheetExists = Not Sheets(SheetName) Is Nothing
End Function


Function CheckList(wb As Workbook) As String
Dim CheckList As String
CountList = 0

If SheetExists("Data") Then
    Set CheckList = wb.Worksheets("Data")
    CountList = CountList + 1
End If

If SheetExists("Динамика KPIs") Then
    Set CheckList = wb.Worksheets("Динамика KPIs")
    CountList = CountList + 1
End If

If CountList = 0 Then
CheckList = "Error"
End If
If CountList = 2 Then
CheckList = "Error"
End If
End Function

Sub UpDateReport()
Dim wb As Workbook
Dim CheckList As String
Dim avFiles As String
Dim List As String

Dim lrow&, lcolumn&, arr()
Dim x As Long, y As Long
Dim sh1 As Worksheet, sh2 As Worksheet

    avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", 1, "Âûáåðèòå îò÷åò ", , False)
    If VarType(avFiles) = vbBoolean Then
        Exit Sub
    End If
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

   Workbooks.Open Filename:=avFiles
   wb = ActiveWorkbook
   List = CheckList(wb)

    Set sh1 = ThisActiveWorkbook.Worksheets("KPI"): Set sh2 = List
    With sh2
        arr = .UsedRange.Value
        sh1.[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    End With
    
        Calculate
        Application.Calculation = xlAutomatic
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True

End Sub
 
Вы что-то вообще непонятное накрутили в коде. Посмотрите внимательно мое последнее сообщение и сделайте правки согласно него, а не что-то там плохо вменяемое от себя.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий(The_Prist) Щербаков, внес ваши правки в код.
Код
Option Explicit
Function SheetExists(SheetName As String) As Boolean
On Error Resume Next
SheetExists = Not Sheets(SheetName) Is Nothing
End Function

Function CheckListSub(wb As Workbook) As String
Dim CountList As Long
CountList = 0

If SheetExists("data") Then
    Set CheckListSub = "Data"
    CountList = CountList + 1
End If

If SheetExists("Динамика KPIs") Then
    Set CheckListSub = "Динамика KPIs"
    CountList = CountList + 1
End If

If CountList = 0 Then
CheckListSub = "Error 0"
End If

If CountList = 2 Then
CheckListSub = "Error 2"
End If

End Function

Sub UpDateReport()
Dim avFiles As String
Dim i As String
Dim NameFile As String
Dim CheckList As String
Dim Database As Workbook
Dim Filename As String

    avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", 1, "Âûáåðèòå îò÷åò ", , False)
    If VarType(avFiles) = vbBoolean Then 'áûëà íàæàòà êíîïêà îòìåíû - âûõîä èç ïðîöåäóðû
        Exit Sub
    End If
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

i = InStrRev(avFiles, "\")
NameFile = Mid(avFiles, i + 1)

Workbooks.Open Filename:=avFiles
Set Database = ActiveWorkbook
CheckList = CheckListSub(Database)
Database.Close False

        Calculate
        Application.Calculation = xlAutomatic
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True

    ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\"
 
    Filename = Application.GetSaveAsFilename("Three KPI.xls", "Three KPI (*.xlsx),", , _
                                             "Êóäà ñîõðàíèòü ãîòîâûé îò÷åò?", "Ñîõðàíèòü")

    If VarType(Filename) = vbBoolean Then
      MsgBox "Íå âûáðàí ïóòü äëÿ ñîõðàíåíèÿ îò÷åòà"
      Exit Sub
    End If

      ActiveWorkbook.SaveAs Filename, FileFormat:=51

End Sub
Выдает ошибку Object required на строке:
Код
Function CheckListSub(wb As Workbook) As String
 
заработало, спасибо.
Оказалось Set мешал
Set CheckListSub = "Data"
 
Все та же проблема типов переменных.
Книга открылась, лист определили.

Далее хочу скопировать все данные из открытой книги в домашную:
Код
Set sh1 = ThisWorkbook.Worksheets("Data"): Set sh2 = Workbooks(NameFile).Worksheets(CheckList)    
     With sh2
       arr = .UsedRange.Value
       sh1.[c2].Resize(UBound(arr), UBound(arr, 2)) = arr
       sh2.Delete
     End With
Но почему то появляется ошибка типов. Исходя из темы корректное обращение к таблицам
ThisWorkbook - это книга в которой лежит макрос т.е. в этой книгу на вкладку Data
переносятся все значения из диапазона UsedRange из книги Workbooks(NameFile) где имя получено в строке 48.

Код
Function SheetExists(SheetName As String) As Boolean
On Error Resume Next
SheetExists = Not Sheets(SheetName) Is Nothing
End Function

Function CheckListSub(wb As Workbook) As String
Dim CountList As Long

CountList = 0

If SheetExists("Data") Then
    CheckListSub = "Data"
    CountList = CountList + 1
End If

If SheetExists("Динамика KPIs") Then
    CheckListSub = "Динамика KPIs"
    CountList = CountList + 1
End If

If CountList = 0 Then
CheckListSub = "Error 0"
End If

If CountList = 2 Then
CheckListSub = "Error 2"
End If

End Function


Sub UpDateReport()
Dim avFiles As String
Dim i As String
Dim NameFile As String
Dim CheckList As String
Dim Database As Workbook

Dim Filename As String

    avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", 1, "Âûáåðèòå îò÷åò ", , False)
    If VarType(avFiles) = vbBoolean Then 'áûëà íàæàòà êíîïêà îòìåíû - âûõîä èç ïðîöåäóðû
        MsgBox "Íå âûáðàí èñòî÷íèê äàííûõ"
        Exit Sub
    End If
    
i = InStrRev(avFiles, "\")
NameFile = Mid(avFiles, i + 1)
Workbooks.Open Filename:=avFiles
Set Database = ActiveWorkbook

CheckList = CheckListSub(Database)

' БЛОК КОПИРОВАНИЯ
Dim lrow&, lcolumn&, arr()
Dim sh1 As Worksheet, sh2 As Worksheet

' ТУТ ОШИБКА ТИПА
Set sh1 = ThisWorkbook.Worksheets("Data"): Set sh2 = Workbooks(NameFile).Worksheets(CheckList)
    With sh2
       arr = .UsedRange.Value
       sh1.[c2].Resize(UBound(arr), UBound(arr, 2)) = arr
       sh2.Delete
     End With
' БЛОК КОПИРОВАНИЯ

Database.Close False

End Sub
Изменено: phelex - 16 Май 2019 13:26:53
 
Друзья, очень нужен ваш свежий взгляд!
 
Код
Set sh1 = ThisWorkbook.Worksheets("Data"): Set sh2 = Workbooks(NameFile).Worksheets(CheckList)    
     With sh2
       arr = .UsedRange.Value
       sh1.[c2].Resize(UBound(arr), UBound(arr, 2)) = arr
       sh2.Delete  'ЭТО ЗАЧЕМ?
     End With


sh2.Delete  Зачем удаляете лист, не закончив конструкцию With... End with?
Попробуйте удалить после, а не внутри конструкции, либо напишите просто .Delete без sh2
Изменено: Nordheim - 16 Май 2019 16:10:27
"Все гениальное просто, а все простое гениально!!!"
Страницы: 1
Читают тему (гостей: 1)
Наверх