Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
   Dim r As Range
   For Each r In Sheets(1).Range("G2,G4,G6,G8,G10,G12,G14,G16,G18,G20,G22,G24,G26,G28,G30,G32,G34,G36,G38,G40,G42,G42,G44,G46,G48,G50,G52,G54,G56,G58,G60,G62,G64,G66,G68,G70,G72,G74,G76,G78,G80,G82,G84,G86,G88,G90,G92,G94,G96,G98,G100,G102,G104,G106,H2,H4,H6,H8,H10,H12,H14,H16,H18,H20,H22,H24,H26,H28,H30").Cells
       If r = "" Then
           If InputBox("не сохраню") <> "123" Then
               Cancel = True: Exit For
           Else
               Exit Sub
           End If
       End If
   Next
End Sub

Function GetRate(ByVal CurrencyName As String, ByVal RateDate As Date) As Single

On Error Resume Next
CurrencyName = UCase(CurrencyName): If Len(CurrencyName) <> 3 Then Exit Function
Set xmldoc = CreateObject("Msxml.DOMDocument"): xmldoc.async = False
url_request = "http://www.cbr.ru/scripts/XML_daily.asp?date_req="; + Format(RateDate, "dd\/mm\/yyyy")

If xmldoc.Load(url_request) <> True Then Exit Function 

Set nodeList = xmldoc.selectNodes("ValCurs"): Set xmlNode = nodeList.Item(0).CloneNode(True)
Set node_attr = xmlNode.Attributes(0): strDate = node_attr.Value
Set nodeList = xmldoc.selectNodes("*/Valute")
For i = 0 To nodeList.Length - 1 ' ïîèñê íóæíîé âàëþòû
Set xmlNode = nodeList.Item(i).CloneNode(True)
If xmlNode.childNodes(1).Text = CurrencyName Then
CurrencyRate = CDbl(xmlNode.childNodes(4).Text)
divisor = Val(xmlNode.childNodes(2).Text)
GetRate = CurrencyRate / divisor
Exit Function
End If
Next
End Function 

Sub sborka()
If MsgBox("Сборка проихзводится на 1 лист, правильно?", vbYesNo + vbDefaultButton2) = 6 Then
Sheets(1).Range("a1").CurrentRegion.Clear
s_ = Sheets.Count
Sheets(2).Range("1:1").Copy Sheets(1).Range("a1")
For i = 2 To s_
    r_ = Sheets(1).Range("a" & Rows.Count).End(xlUp).Row + 1
    Sheets(i).Range("a1").CurrentRegion.Offset(1).Copy Sheets(1).Range("a" & r_)
    Range("d" & r_) = Sheets(i).Name
Next
    r_ = Sheets(1).Range("a" & Rows.Count).End(xlUp).Row
    Range("d2:d" & r_).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    Range("d2:d" & r_).Value = Range("D2:D" & r_).Value
End If
End Sub