Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » Ксения
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1
[ Закрыто] Дашборд из файлов в папке, Консолидация информации из файлов
 
#
30.05.2025 10:32:44
Sanja,Штраф за то что вы обиделись? Смешно и очень вас жаль, что пытаетесь так самоутвердиться, штрафы раздавайте другим, так как нарушений тут нет. Можете дать бан если сильно вас задела моя тема, кроме вас никого не задело мое сообщение.
Интеллект заключается не в том, чтобы знать все ответы, а в том, чтобы задавать правильные вопросы.
 
Перейти    
[ Закрыто] Дашборд из файлов в папке, Консолидация информации из файлов
 
#
30.05.2025 10:30:00
Msi2102, Всем, получилось через нейросеть сделать. Код на VBA выше прикрепила, может кому-то пригодится  
Интеллект заключается не в том, чтобы знать все ответы, а в том, чтобы задавать правильные вопросы.
 
Перейти    
[ Закрыто] Дашборд из файлов в папке, Консолидация информации из файлов
 
#
30.05.2025 09:44:53
Msi2102, да не, нейросеть все сделала, спасибо всем, файлов 5 и они мелкие в основном, всего по всем файлам 49 строк

Всем спасибо!  
Интеллект заключается не в том, чтобы знать все ответы, а в том, чтобы задавать правильные вопросы.
 
Перейти    
[ Закрыто] Дашборд из файлов в папке, Консолидация информации из файлов
 
#
30.05.2025 09:43:41
Sanja, а вы пришли подискутировать или помочь? Если настолько скучно, листайте другие темы, мы дружелюбно общаемся, а если уточняющие вопросы не несут смысла и логики, то это флуд. Спасибо за участие в обсуждении и хорошего вам дня!
Интеллект заключается не в том, чтобы знать все ответы, а в том, чтобы задавать правильные вопросы.
 
Перейти    
[ Закрыто] Дашборд из файлов в папке, Консолидация информации из файлов
 
#
30.05.2025 08:30:32
Veniamin Loginov, Не, сама я соберу, а вот руководители не смогут  
Изменено: Ксения - 31.05.2025 18:56:11
Интеллект заключается не в том, чтобы знать все ответы, а в том, чтобы задавать правильные вопросы.
 
Перейти    
[ Закрыто] Дашборд из файлов в папке, Консолидация информации из файлов
 
#
30.05.2025 08:30:12
Hugo, вот полностью рабочий код:
Код
Sub АвтозаполнениеДашборда()
    Dim wsDashboard As Worksheet
    Set wsDashboard = ThisWorkbook.Sheets(1)

    Dim Path As String, FileName As String
    Path = ThisWorkbook.Path & "\"
    Dim wbSource As Workbook, wsSource As Worksheet

    Dim DashLastRow As Long, DashRow As Long
    DashLastRow = wsDashboard.Cells(wsDashboard.Rows.Count, "D").End(xlUp).Row

    Dim DashDateTitle As String
    DashDateTitle = wsDashboard.Range("K1").Value

    Dim Done As Long
    Application.ScreenUpdating = False
    Application.StatusBar = "Заполнение начато..."

    ' Показываем прогресс-бар
    frmStatusBar.lblProgress.Width = 0
    frmStatusBar.lblPercent.Caption = "0%"
    frmStatusBar.lblPercent.Left = frmStatusBar.FrameBar.Left + (frmStatusBar.FrameBar.Width - frmStatusBar.lblPercent.Width) / 2
    frmStatusBar.lblStatus.Caption = "Заполнение..."
    frmStatusBar.Show vbModeless

    For DashRow = 2 To DashLastRow
        Dim DashMetrika As String, DashSod As String
        DashMetrika = Trim(wsDashboard.Cells(DashRow, "D").Value)
        DashSod = Trim(wsDashboard.Cells(DashRow, "E").Value)
        If DashMetrika = "" Or DashSod = "" Then GoTo SkipDashRow

        Dim FoundValue As Variant, FoundPct As Variant, FoundConf As Variant
        FoundValue = "": FoundPct = "": FoundConf = ""
        Dim IsFound As Boolean: IsFound = False

        FileName = Dir(Path & "*.xls*")
        Do While FileName <> ""
            If FileName <> ThisWorkbook.Name Then
                Set wbSource = Workbooks.Open(Path & FileName, ReadOnly:=True)
                Set wsSource = wbSource.Sheets(1)

                Dim DateCol As Integer, Col As Integer
                DateCol = 0
                For Col = 1 To wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
                    If InStr(wsSource.Cells(1, Col).Text, DashDateTitle) > 0 Then
                        DateCol = Col
                        Exit For
                    End If
                Next Col

                If DateCol > 0 Then
                    Dim SrcLastRow As Long, SrcRow As Long
                    SrcLastRow = wsSource.Cells(wsSource.Rows.Count, "D").End(xlUp).Row
                    For SrcRow = 2 To SrcLastRow
                        Dim SrcMetrika As String, SrcSod As String
                        SrcMetrika = Trim(wsSource.Cells(SrcRow, "D").Value)
                        SrcSod = Trim(wsSource.Cells(SrcRow, "E").Value)
                        If SrcMetrika = DashMetrika And SrcSod = DashSod Then
                            FoundValue = wsSource.Cells(SrcRow, DateCol).Value
                            FoundPct = wsSource.Cells(SrcRow, DateCol + 1).Value
                            FoundConf = wsSource.Cells(SrcRow, DateCol + 2).Value
                            IsFound = True
                            Exit For
                        End If
                    Next SrcRow
                End If

                wbSource.Close False
                If IsFound Then Exit Do
            End If
            FileName = Dir
        Loop

        ' Записываем только если нашли!
        If IsFound Then
            wsDashboard.Cells(DashRow, "K").Value = FoundValue
            wsDashboard.Cells(DashRow, "L").Value = FoundPct
            wsDashboard.Cells(DashRow, "M").Value = FoundConf
        End If

SkipDashRow:
        ' --- ПРОГРЕСС ---
        Done = DashRow - 1
        Dim Progress As Double
        Progress = Done / (DashLastRow - 1)
        Application.StatusBar = "Заполнение: " & Format(Progress, "0%") & _
            " (" & Done & " из " & DashLastRow - 1 & ")"
        ' --- ОБНОВЛЕНИЕ ПРОГРЕСС-БАРА ---
        frmStatusBar.lblProgress.Width = frmStatusBar.FrameBar.Width * Progress
        frmStatusBar.lblPercent.Caption = Format(Progress, "0%")
        frmStatusBar.lblPercent.Left = frmStatusBar.FrameBar.Left + (frmStatusBar.FrameBar.Width - frmStatusBar.lblPercent.Width) / 2
        frmStatusBar.lblStatus.Caption = "Обработка строки: " & DashRow & " из " & DashLastRow
        DoEvents
    Next DashRow

    Application.StatusBar = False
    Application.ScreenUpdating = True
    Unload frmStatusBar
    MsgBox "Заполнение завершено!", vbInformation
End Sub
Интеллект заключается не в том, чтобы знать все ответы, а в том, чтобы задавать правильные вопросы.
 
Перейти    
[ Закрыто] Дашборд из файлов в папке, Консолидация информации из файлов
 
#
29.05.2025 13:22:08
Hugo, смотрите, я файлики прикрепила,
Слово "тест" подтягивает макрос, так же и с остальными, метрики и содержание сделала уникальными
Изменено: Ксения - 31.05.2025 18:56:22
Интеллект заключается не в том, чтобы знать все ответы, а в том, чтобы задавать правильные вопросы.
 
Перейти    
[ Закрыто] Дашборд из файлов в папке, Консолидация информации из файлов
 
#
29.05.2025 13:08:29
Hugo,
Цитата
написал:
нужно заполнить данными только 3 столбца K, L, M
Значение% достиженияУверенность
Все верно, нужно в дашборде заполнить три столба  на основании недели в ячейке K1
Взять эту информацию из файлов которые я прикрепила.
частично макрос решил эту проблему. Просто долго обрабатывает и не думаю, что будет работать в сетевой папке  
Изменено: Ксения - 31.05.2025 18:56:26
Интеллект заключается не в том, чтобы знать все ответы, а в том, чтобы задавать правильные вопросы.
 
Перейти    
[ Закрыто] Дашборд из файлов в папке, Консолидация информации из файлов
 
#
29.05.2025 12:55:08
Hugo, Суть понятна тем кто ответил и помог. Спасибо Никита Дворец
Что вам непонятно?
Что необходимо подтянуть данные за неделю по трем показателям в дашборд? Если да, тогда вам не в эту тему.

Скрытый текст

Не засоряйте обсуждение, если не можете помочь, спасибо.
Хорошего дня!
Интеллект заключается не в том, чтобы знать все ответы, а в том, чтобы задавать правильные вопросы.
 
Перейти    
[ Закрыто] Дашборд из файлов в папке, Консолидация информации из файлов
 
#
29.05.2025 12:20:14
Hugo, плевать на содержание, извините если неправильно донесла суть  
Интеллект заключается не в том, чтобы знать все ответы, а в том, чтобы задавать правильные вопросы.
 
Перейти    
[ Закрыто] Дашборд из файлов в папке, Консолидация информации из файлов
 
#
29.05.2025 11:48:39
Никита Дворец, я сейчас метрики столбец (D) и содержание столбец (E) сделала уникальными, ну просто протянула


вот что получилось благодаря нейросетям
Скрытый текст
, но не совсем корректно отрабатывает:
Код
Sub АвтозаполнениеДашборда()
    Dim wsDashboard As Worksheet
    Set wsDashboard = ThisWorkbook.Sheets(1)

    Dim Path As String, FileName As String
    Path = ThisWorkbook.Path & "\"
    Dim wbSource As Workbook, wsSource As Worksheet

    Dim DashLastRow As Long, DashRow As Long
    DashLastRow = wsDashboard.Cells(wsDashboard.Rows.Count, "D").End(xlUp).Row

    Dim DashDateTitle As String
    DashDateTitle = wsDashboard.Range("K1").Value

    Dim Done As Long
    Application.ScreenUpdating = False
    Application.StatusBar = "Заполнение начато..."

    frmStatusBar.lblProgress.Width = 0
    frmStatusBar.lblPercent.Caption = "0%"
    frmStatusBar.lblPercent.Left = frmStatusBar.FrameBar.Left + (frmStatusBar.FrameBar.Width - frmStatusBar.lblPercent.Width) / 2
    frmStatusBar.lblStatus.Caption = "Заполнение..."
    frmStatusBar.Show vbModeless

    For DashRow = 2 To DashLastRow
        Dim DashMetrika As String, DashSod As String
        DashMetrika = Trim(wsDashboard.Cells(DashRow, "D").Value)
        DashSod = Trim(wsDashboard.Cells(DashRow, "E").Value)
        If DashMetrika = "" Or DashSod = "" Then GoTo SkipDashRow

        Dim FoundValue As Variant, FoundPct As Variant, FoundConf As Variant
        FoundValue = "": FoundPct = "": FoundConf = ""
        Dim IsFound As Boolean: IsFound = False

        FileName = Dir(Path & "*.xls*")
        Do While FileName <> ""
            If FileName <> ThisWorkbook.Name Then
                Set wbSource = Workbooks.Open(Path & FileName, ReadOnly:=True)
                Set wsSource = wbSource.Sheets(1)

                Dim DateCol As Integer, Col As Integer
                DateCol = 0
                For Col = 1 To wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
                    If InStr(wsSource.Cells(1, Col).Text, DashDateTitle) > 0 Then
                        DateCol = Col
                        Exit For
                    End If
                Next Col

                If DateCol > 0 Then
                    Dim SrcLastRow As Long, SrcRow As Long
                    SrcLastRow = wsSource.Cells(wsSource.Rows.Count, "D").End(xlUp).Row
                    For SrcRow = 2 To SrcLastRow
                        Dim SrcMetrika As String, SrcSod As String
                        SrcMetrika = Trim(wsSource.Cells(SrcRow, "D").Value)
                        SrcSod = Trim(wsSource.Cells(SrcRow, "E").Value)
                        If SrcMetrika = DashMetrika And SrcSod = DashSod Then
                            FoundValue = wsSource.Cells(SrcRow, DateCol).Value
                            FoundPct = wsSource.Cells(SrcRow, DateCol + 1).Value
                            FoundConf = wsSource.Cells(SrcRow, DateCol + 2).Value
                            IsFound = True
                            Exit For
                        End If
                    Next SrcRow
                End If

                wbSource.Close False
                If IsFound Then Exit Do
            End If
            FileName = Dir
        Loop

        If IsFound Then
            wsDashboard.Cells(DashRow, "K").Value = FoundValue
            wsDashboard.Cells(DashRow, "L").Value = FoundPct
            wsDashboard.Cells(DashRow, "M").Value = FoundConf
        End If

SkipDashRow:
        Done = DashRow - 1
        Dim Progress As Double
        Progress = Done / (DashLastRow - 1)
        Application.StatusBar = "Заполнение: " & Format(Progress, "0%") & _
            " (" & Done & " из " & DashLastRow - 1 & ")"
        frmStatusBar.lblProgress.Width = frmStatusBar.FrameBar.Width * Progress
        frmStatusBar.lblPercent.Caption = Format(Progress, "0%")
        frmStatusBar.lblPercent.Left = frmStatusBar.FrameBar.Left + (frmStatusBar.FrameBar.Width - frmStatusBar.lblPercent.Width) / 2
        frmStatusBar.lblStatus.Caption = "Обработка строки: " & DashRow & " из " & DashLastRow
        DoEvents
    Next DashRow

    Application.StatusBar = False
    Application.ScreenUpdating = True
    Unload frmStatusBar
    MsgBox "Заполнение завершено!", vbInformation
End Sub
Интеллект заключается не в том, чтобы знать все ответы, а в том, чтобы задавать правильные вопросы.
 
Перейти    
[ Закрыто] Дашборд из файлов в папке, Консолидация информации из файлов
 
#
28.05.2025 18:46:34
Msi2102, там файлы не более 10 строк)  
Интеллект заключается не в том, чтобы знать все ответы, а в том, чтобы задавать правильные вопросы.
 
Перейти    
[ Закрыто] Дашборд из файлов в папке, Консолидация информации из файлов
 
#
28.05.2025 18:21:32
спасибо разобралась в макросах, благо есть AI помощники, тут я так понимаю такие вещи за деньги только  
Интеллект заключается не в том, чтобы знать все ответы, а в том, чтобы задавать правильные вопросы.
 
Перейти    
Страницы: 1
Наверх