Здравствуйте, дорогие участники форума. Есть один такой вопрос, очень сложный. Есть корпоративная программа("Шахты"), которая выгружает файл в эксель формате при помощи макроса. Есть ли возможность сделать работу макроса в обратной форме, чтоб при изменение исходных файлов в эксель их трансформировать в нужный формат. Спасибо заранее, за ответы и помощь. Исходный макрос выглядит вот так:
Код
ub MainMacro()
On Error Resume Next
ThisWorkbook.Sheets(1).Name = "Start"
For i = ThisWorkbook.Sheets.Count To 1 Step -1
If ThisWorkbook.Sheets(i).Name <> "Start" Then
ThisWorkbook.Sheets(i).Delete
End If
Next
CopyNote
CopyKaf
CopyDiag
CopyVex
CopyGEK
CopyGAK
CopyKP
CopyPractices
CopyCourses
CopyPivotTable
CopyCmptDistr
CopyCmptList
CopySpecAsp
CopyReduce
CopyPlan
CopyPlanSvod
CopyGYP
CopyTitle
For i = ThisWorkbook.Sheets.Count To 1 Step -1
With ThisWorkbook.Sheets(i)
.Select
.PageSetup.LeftMargin = Application.InchesToPoints(0.393700787401575)
.PageSetup.RightMargin = Application.InchesToPoints(0.393700787401575)
.PageSetup.TopMargin = Application.InchesToPoints(0.393700787401575)
.PageSetup.BottomMargin = Application.InchesToPoints(0.393700787401575)
.PageSetup.HeaderMargin = Application.InchesToPoints(0)
.PageSetup.FooterMargin = Application.InchesToPoints(0)
.PageSetup.Orientation = xlLandscape
Cells.Select
Selection.NumberFormat = "@"
.Range("A1").Select
End With
Next
ActiveWindow.TabRatio = 0.75
Sheets("Start").Visible = False
Sheets("Титул").Select
End Sub
Sub CopyDiag()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetDiag.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "Диаграмма курсов"
ActiveWindow.DisplayGridlines = False
Application.ScreenUpdating = False
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyVex()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetVex.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "Выпускные экзамены"
ActiveWindow.DisplayGridlines = False
Application.ScreenUpdating = False
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyGAK()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetGAK.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "ГЭК (ВКР)"
ActiveWindow.DisplayGridlines = False
Application.ScreenUpdating = False
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyKP()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetKP.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "Курсовые"
ActiveWindow.DisplayGridlines = False
Application.ScreenUpdating = False
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyGEK()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetGEK.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "ГЭК"
ActiveWindow.DisplayGridlines = False
Application.ScreenUpdating = False
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyPractices()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetPractices.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "Практики"
ActiveWindow.DisplayGridlines = False
Application.ScreenUpdating = False
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyNote()
'On Error Resume Next
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetNote.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With xlsA.Sheets(1) 'здесь путь, откуда копировать
.[A1:H100].Copy [a1] 'а1 - это куда копировать
'.Parent.Close SaveChanges:=False ' или True, закрываем источник
End With
With ThisWorkbook.Sheets(1)
.Select
.Name = "Примечание"
ActiveWindow.DisplayGridlines = False
'.Rows(1).RowHeight = 15
'.Columns(1).ColumnWidth = 2.5
' .Cells(1, 2).Value = "Пояснения"
' .Cells(1, 2).Font.Name = "Tahoma"
' .Cells(1, 2).Font.Bold = True
' .Cells(1, 2).Font.Size = 9
' .Range(.Cells(1, 2), .Cells(1, 4)).Interior.ColorIndex = 2
' .Range(.Cells(1, 2), .Cells(1, 4)).Merge
'.Range(.Cells(1, 1), .Cells(101, 1)).Interior.ColorIndex = 2
Application.ScreenUpdating = False
'AutoFitMergedCellRowHeight [a1:h200]
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyKaf()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetKaf.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "Кафедры"
ActiveWindow.DisplayGridlines = False
Application.ScreenUpdating = False
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopySpecAsp()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetSpec.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "Спец"
ActiveWindow.DisplayGridlines = False
Application.ScreenUpdating = False
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyTitle()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetTitle.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.PageSetup.Zoom = False
.PageSetup.FitToPagesWide = 1
.PageSetup.FitToPagesTall = False
.Name = "Титул"
ActiveWindow.DisplayGridlines = False
.Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
.Rows("1:1").Select
Selection.Delete Shift:=xlUp
.Cells(1, 1).Select
For r = 1 To 255
For cl = 1 To 255
If .Cells(r, cl).Interior.ColorIndex = 20 Then
.Cells(r, cl).Interior.ColorIndex = 35
End If
Next cl
Next r
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyGYP()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetGYP.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.PageSetup.Zoom = False
.PageSetup.FitToPagesWide = 1
.PageSetup.FitToPagesTall = False
.Name = "График"
ActiveWindow.DisplayGridlines = False
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Dim r As Integer
Dim cl As Integer
Dim bot As Integer
Dim rght As Integer
Dim e As Integer
e = 53
'вертикальный текст в шапке
For r = 2 To 3
For cl = 2 To e
If .Cells(r, cl).Value Like "*-*" Then
.Cells(r, cl).Orientation = 90
End If
Next cl
Next r
For r = 256 To 1 Step -1
If .Cells(r, 1).Value <> "" Then
bot = r
Exit For
End If
Next r
For r = 1 To bot
If .Cells(r, 1).Value Like "*Сводные данные*" Then
rsvod = r
Exit For
End If
Next r
For cl = 256 To 1 Step -1
If .Cells(rsvod + 1, cl).Value <> "" Or .Cells(rsvod + 2, cl).Value <> "" Then
rght = cl
Exit For
End If
Next cl
For r = 1 To bot
If .Cells(r, 1).Value Like "*График сессий*" Then
e = 72
Exit For
End If
' If .Cells(r, 1).Value = " Студентов" Or .Cells(r, 1).Value = " Групп" Then
' For cl = 2 To rght
' If Mid(.Cells(rsvod + 1, cl).Value, 1, 4) = "Курс" Then
' .Cells(r, cl).Interior.ColorIndex = 35
' Else
' .Cells(r, cl).Interior.ColorIndex = 2
' End If
' Next cl
' End If
Next r
.Range(.Cells(rsvod + 1, 1), .Cells(bot, rght)).Font.Size = 10
Dim ln As Integer
ln = 0
If rght < e Then
rght = e
End If
For r = 1 To bot
For cl = 1 To rght
If Mid(.Cells(r, cl).Value, 1, 3) = "tdp" Then
With .Cells(r, cl).Interior
.Pattern = xlLightUp
.PatternColorIndex = 13
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
ln = Len(.Cells(r, cl).Value)
If ln > 0 Then
If Mid(.Cells(r, cl).Value, ln, 1) = "#" Then
.Cells(r, cl).Value = Replace(.Cells(r, cl).Value, "#", "")
.Cells(r, cl).Value = Replace(.Cells(r, cl).Value, ".", "")
'.Cells(r, cl).Font.ColorIndex = 16
With .Cells(r, cl).Interior
.Pattern = xlGray50
.PatternColorIndex = 16
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf Mid(.Cells(r, cl).Value, ln, 1) = "." Then
.Cells(r, cl).Value = Replace(.Cells(r, cl).Value, ".", "")
With .Cells(r, cl).Interior
'.Pattern = xlSolid
'.Pattern = xlGray16
'.PatternColorIndex = xlAutomatic
.Color = 10079487
'.TintAndShade = 0
'.PatternTintAndShade = 0
End With
End If
End If
' Range("B13:Z18").Select
' With Selection.Font
' .Name = "Tahoma"
' .FontStyle = "обычный"
' .Size = 8
' .Strikethrough = False
' .Superscript = False
' .Subscript = False
' .OutlineFont = False
' .Shadow = False
' .Underline = xlUnderlineStyleNone
' .ThemeColor = xlThemeColorLight1
' .TintAndShade = 0.349986267
' .ThemeFont = xlThemeFontNone
' End With
' With Selection.Interior
' .Pattern = xlGray50
' .PatternThemeColor = xlThemeColorLight1
' .ColorIndex = 2
' .TintAndShade = 0
' .PatternTintAndShade = 0.499984740745262
' End With
' Range("AC13:AC18").Select
If Mid(.Cells(r, cl).Value, 1, 3) = "tdp" Then
.Cells(r, cl).Value = ""
End If
Next cl
Next r
.Cells(2, 2).Select
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyPlan()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetPlan.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Name = "План"
For i = 6 To 1250
If .Cells(i, 2).Value <> "" Then .Rows(i).EntireRow.AutoFit
If .Cells(i, 1).Value = "white" Then .Cells(i, 1).Value = ""
If .Cells(i, 1).Value = "invalid" Then .Cells(i, 1).Value = "Адаптац."
Next
End With
'xlsA.Close
On Error Resume Next
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyPlanSvod()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetSPlan.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Name = "ПланСвод"
For i = 6 To 1250
If .Cells(i, 2).Value <> "" Then .Rows(i).EntireRow.AutoFit
If .Cells(i, 1).Value = "white" Then .Cells(i, 1).Value = ""
If .Cells(i, 1).Value = "invalid" Then .Cells(i, 1).Value = "Адаптац."
Next
End With
On Error Resume Next
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyCmptList()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetCmptList.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "Компетенции"
ActiveWindow.DisplayGridlines = False
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyCmptDistr()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetCmptDD.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "Компетенции(2)"
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyCoursesNew()
Application.ScreenUpdating = False
Dim iC As Byte
For i = 1 To 7
iC = 8 - i
'On Error Resume Next
openxlsa = ThisWorkbook.Path & "\Sheets\sheetCourse" & iC & ".xls"
If Dir(openxlsa) <> "" Then
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "Курс" & iC
ActiveWindow.DisplayGridlines = False
ActiveWindow.Zoom = 85
For cl = 1 To 21
.Columns(1).Delete
Next cl
.Rows(7).EntireRow.Hidden = False
With .Range(.Cells(8, 22), .Cells(12, 25))
.Interior.ColorIndex = xlNone
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
.Borders(xlEdgeLeft).LineStyle = xlNone
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
For rw = 1000 To 15 Step -1
If .Rows(rw).EntireRow.Hidden Then
.Rows(rw).Delete
End If
Next rw
.Range("V8:Y8").Select
ActiveWindow.FreezePanes = True
End With
xlsA.Close
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub CopyReduce()
Application.ScreenUpdating = False
Dim lastc As Integer
Dim lastr As Integer
'On Error Resume Next
openxlsa = ThisWorkbook.Path & "\Sheets\sheetReduce.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "Переаттестовано"
lastc = 0
lastr = 0
For x = 50 To 1 Step -1
If .Cells(3, x).Value <> "" Then
lastc = x
Exit For
End If
Next x
For y = 150 To 1 Step -1
If .Cells(y, 13).Value <> "" Then
lastr = y
Exit For
End If
Next y
With .Range(.Cells(1, 1), .Cells(lastr, lastc))
'Range(Cells(1, 1), Cells(138, 29)).Select
.Interior.ColorIndex = xlNone
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Sub CopyCourses()
Application.ScreenUpdating = False
Dim iC As Byte
Dim lastc As Integer
Dim lastr As Integer
For i = 1 To 7
iC = 8 - i
'On Error Resume Next
openxlsa = ThisWorkbook.Path & "\Sheets\sheetCourse" & iC & ".xls"
If Dir(openxlsa) <> "" Then
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "Курс" & iC
lastc = 0
lastr = 0
For x = 30 To 1 Step -1
If .Cells(3, x).Value <> "" Then
lastc = x
Exit For
End If
Next x
For y = 150 To 1 Step -1
If .Cells(y, 13).Value <> "" Then
lastr = y
Exit For
End If
Next y
With .Range(.Cells(1, 1), .Cells(lastr, lastc))
'Range(Cells(1, 1), Cells(138, 29)).Select
.NumberFormat = "@"
.Interior.ColorIndex = xlNone
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End With
xlsA.Close
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub CopyPivotTable()
Application.ScreenUpdating = False
openxlsa = ThisWorkbook.Path & "\Sheets\sheetPivotTable.xls"
If Dir(openxlsa) = "" Then
Exit Sub
End If
Set xlsA = Workbooks.Open(Filename:=openxlsa, ReadOnly:=True)
xlsA.Sheets(1).Copy Before:=ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(1)
.Select
.Name = "Свод"
ActiveWindow.DisplayGridlines = False
For r = 1 To 30
If .Cells(r, 2).Value > "" Then
Call RangeBordersOutside(.Range(.Cells(r, 1), .Cells(r, 2)), xlThin)
Call RangeBordersInside(.Range(.Cells(r, 1), .Cells(r, 2)), xlThin)
If InStr(1, .Cells(r, 1).Value, ".") > 0 Then
.Range(.Cells(r, 1), .Cells(r, 2)).Interior.ColorIndex = 34
.Cells(r, 10).Interior.ColorIndex = 34
For cl = 13 To 255
If .Cells(2, cl).Value = "Всего" Then
.Cells(r, cl).Interior.ColorIndex = 34
End If
Next
End If
End If
Next r
End With
xlsA.Close
Application.ScreenUpdating = True
End Sub
Private Sub RangeBordersOutside(Rng As Range, xlW As Long)
With Rng
With .Borders(xlTop)
.LineStyle = xlContinuous
.Weight = xlW
.ColorIndex = xlAutomatic
End With
With .Borders(xlBottom)
.LineStyle = xlContinuous
.Weight = xlW
.ColorIndex = xlAutomatic
End With
With .Borders(xlLeft)
.LineStyle = xlContinuous
.Weight = xlW
.ColorIndex = xlAutomatic
End With
With .Borders(xlRight)
.LineStyle = xlContinuous
.Weight = xlW
.ColorIndex = xlAutomatic
End With
End With
End Sub
Private Sub RangeBordersInside(Rng As Range, xlW As Long)
On Error Resume Next
With Rng
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlW
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlW
.ColorIndex = xlAutomatic
End With
End With
End Sub
'Sub ttt()
' Set objExcel = New Excel.Application
' Set wbhidden = objExcel.Workbooks.Open("c:\Macros\Primeri\Excel\check.xls")
'
' Cells(1, 10).Value = wbhidden.Sheets(1).Cells(1, 1)
'
' wbhidden.Close ' обязательно при выходе из кода
' Set objExcel = Nothing ' обязательно при выходе из кода
'End Sub
'openxlsb = Application _
' .GetOpenFilename("Файл-источник (*.xls), *.xls")
'Set xlsb = Workbooks.Open(Filename:=openxlsb, ReadOnly:=True)