Excel Macro Help - Укладка макросов - PullRequest
Новая
       4

Excel Macro Help - Укладка макросов

0 голосов
/ 14 декабря 2010

Я использую следующую подпрограмму для объединения нескольких файлов Excel из одной папки в одну рабочую книгу с несколькими рабочими листами. 

Sub Merge2MultiSheets()

Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "C:\MyPath" ' <-- Insert Absolute Folder Location
Set wbDst = Workbooks.Add(xlWBATWorksheet)
strFilename = Dir(MyPath & "\*.xls", vbNormal)

If Len(strFilename) = 0 Then Exit Sub

Do Until strFilename = ""            
    Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)                
    Set wsSrc = wbSrc.Worksheets(1)                
    wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)                
    wbSrc.Close False            
    strFilename = Dir()            
Loop
wbDst.Worksheets(1).Delete

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Конечный продукт представляет собой файл Excel с несколькими листами (а также с одним пустым листом 1). Мне было интересно, как я могу применить другой макрос к этой недавно созданной Рабочей книге. В качестве примера я хотел бы, чтобы все рабочие листы в этой новой рабочей книге были выделены жирным шрифтом и окрашены в определенные заголовки, а пустой лист был удален.

например: 

Sub Headers()

Rows("1:1").Select
Selection.Font.Bold = True
With Selection.Interior
    .ColorIndex = 37
    .Pattern = xlSolid
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With

End Sub

Ответы [ 3 ]

1 голос
/ 14 декабря 2010 
Sheets.Select       'selects all sheets'
Rows("1:1").Select
Selection.Interior.ColorIndex = 37
0 голосов
/ 14 декабря 2010

Этот код будет выполнять следующее:

1) Сначала удалите Sheet1, как вы просили в своем сообщении

2) Отформатируйте верхнюю строку в оставшихся листах 

Sub Headers()
Dim wkSheet As Worksheet

//Delete Sheet1. Note that alerts are turned off otherwise you are prompted with a dialog box to check you want to delete sheet1
Application.DisplayAlerts = False
Worksheets("Sheet1").Delete
Application.DisplayAlerts = False

//Loop through each worksheet in workbook sheet collection
For Each wkSheet In ActiveWorkbook.Worksheets
    With wkSheet.Rows("1:1")
        .Interior.ColorIndex = 37
        //Add additional formatting requirements here
    End With
Next

End Sub
0 голосов
/ 14 декабря 2010

Добавьте параметр в заголовки, который указывает лист, а затем вызовите подпрограмму где-нибудь в цикле Do после копии, например: 

Call Headers(wbDst.Worksheets(wbDst.Worksheets.Count))

с вашим вторым сабвуфером, похожим на это: 

Sub Headers(workingSheet As Worksheet)

workingSheet.Rows("1:1").Select
Selection.Font.Bold = True
With Selection.Interior
.
.
.
...