Страницы: 1
RSS
Изменить заливку ячейки на листах книги или книг папки
 
добрый день. в Power Query есть непредсказуемый UsedRange. здесь можно узнать подробнее. хотелось бы сделать этот Range предсказуемым. не могли бы написать макрос, который бы на каждом листе изменял заливку в ячейке А1. выбор адреса только книги или адреса папки  всех книг находится в ячейке А1 листа РЕЗУЛЬТАТ. то есть макрос берет адрес из ячейки А1. если там адрес папки, то во всех книгах этой папки на листах надо изменить заливку ячейки А1. если адрес только книги, то заливку изменить только на листах этой книги. как то так. на всякий случай макрорекордером записал замену заливки ячейки А1. в ячейке А3 единицей или нулем можно менять адрес в ячейке А1
Код
Sub aaaa1()
    Range("A1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 16711679
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
End Sub
 
может, можно изменить макрос от Kuzmich в этой теме? или изменить макросы из этого сайта?
Изменено: artyrH - 24.06.2019 22:27:52
 
макрос интуитивно переделал, но он зависает. еще каждый раз сообщения появляются при открытии и закрытии файлов. может, посмотрит кто чего там нужно
 
Доброе время суток.
Вариант, обработку ошибок не делал (ну, почти).
Успехов.
 
Тёзка, Мяв!
А ссылочкой, где по русски расшифрован ColorizeA1OfBook не поделишься?
 
Цитата
RAN написал:
А ссылочкой, где по русски расшифрован ColorizeA1OfBook не поделишься?
Привет, тёзка. Прости, ночнеет, туплю не по детски. О какой ссылочке и расшифровке идёт речь? Вроде весь код в Module2 выложенной книги... Или нет?
 
Андрей VG, спасибо
я сам тоже кое что собрал из того что нашел)
Код
Sub ЗаменаНаВсехЛистахВсехКниг()
Dim Wb As Workbook              'текущая книга ( где исполняемый код)
Dim tWb As Workbook             'открываемая книга
Dim ShtOut As Worksheet         'лист в текущей книге
Dim ShtIn As Worksheet          'лист в открываемом файле
Dim iTempFileName As String     'имя очерёдного открываемого файла
Dim iPath As String             'путь к папке, где лежат все файлы
Dim iNumFiles As Long           'количество открываемых файлов
Dim FD As FileDialog
Dim i As Long
Application.ScreenUpdating = False

            iPath = Range("A1").Value



    Set Wb = ThisWorkbook       'эта книга
    
    Set ShtOut = Wb.Worksheets("РЕЗУЛЬТАТ")

    iNumFiles = 0


    On Error GoTo ErrHandler

    iTempFileName = Dir(iPath & "*.xlsx")
    
    Do While iTempFileName <> ""
        iNumFiles = iNumFiles + 1
        
        Set tWb = Workbooks.Open(Filename:=iPath & iTempFileName, UpdateLinks:=False, ReadOnly:=False)
        
        'В СтатусБаре отображаем имя открываемого файла
        Application.StatusBar = "Обработка файла: " & tWb.Name
 
        
        ShtOut.Range("A1").Copy
        For i = 1 To Sheets.Count
            Set ShtIn = tWb.Sheets(i)
            
            
            
            ShtIn.Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone

        
        Next i

        tWb.Close SaveChanges:=True         'закрыть книгу с сохранением изменений
        
        iTempFileName = Dir                 'следующая книга для внесения изменений
        Set ShtIn = Nothing                 'обнуляем переменную после закрытия книги
    Loop
    
    Application.StatusBar = False    'сбрасываем СтатусБар
    
    MsgBox "Изменения произведены в " & iNumFiles & " файлах в папке: " & Chr(10) & iPath, vbInformation, "Конец"
    Exit Sub

ErrHandler:
    MsgBox "Произошла ошибка!", 48, "Ошибка"

Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
Sub a2b2c()
Application.ScreenUpdating = False
Sheets("РЕЗУЛЬТАТ").Range("A1").Copy

For i = 1 To Sheets.Count
   With Sheets(i)
      .Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
   End With
Next i

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Sub qq33q()
Dim iPath As String

iPath = Range("A1").Value
        
        If iPath Like "*.xlsm" Then a2b2c Else ЗаменаНаВсехЛистахВсехКниг

End Sub
 
Что такое FileSystemObject, и где про это почитать, я знаю.
А подо что, и с какой закуской потреблять Namespace и иже с ним?
 
Цитата
artyrH написал:
я сам тоже кое что собрал из того что нашел)
Артур, да всё у вас не плохо. Я собственно подзадачу разбирал, как определить, что задано в ячейке папка или файл, если имя введено как c:\path\somename
Цитата
RAN написал:
А подо что, и с какой закуской потреблять Namespace и иже с ним?
Ну, на русском есть или нет, не знаю. Я обычно тут смотрю Shell object.
Правда, в силу асинхронности метода Filter лучше делать так
Код
    Dim vCount As Long
    '.....
        pItems.Filter &H40, "*.xls*"
        vCount = pItems.Count
        Do While vCount <> pItems.Count
            vCount = pItems.Count
        Loop

Да, думаю, ты об этом объекте уже читал, его часто упоминают, когда нужно что-то достать из zip архива.
Updated.
Совсем забыл, что описание есть в классическом месте Объект Shell, причём как требовалось - на русском.
Изменено: Андрей VG - 24.06.2019 23:19:30
 
мУрси. На досуге погрызу.
Страницы: 1
Наверх