Attribute VB_Name = "RRO"

Public Const KEY_QUERY_VALUE = &H8
Public Const REG_SZ = 1
Public Const REG_EXPAND_SZ = 2
Public Const REG_BINARY = 3
Public Const REG_DWORD = 4
Public Const REG_MULTI_SZ = 7
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const ERROR_SUCCESS = 0&
Public Const ERROR_NO_MORE_ITEMS = 259

#If Win64 Then
    Public Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
    Public Declare PtrSafe Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
    Public Declare PtrSafe Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
    Public Declare PtrSafe Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
    Public Declare PtrSafe Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
    Public Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
    Public Declare PtrSafe Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
    Public Declare PtrSafe Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
#Else
    Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
    Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
    Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
    Public Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
    Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
    Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
    Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
    Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
#End If

Sub ExportSheetData()
    Dim oObjSheet As Worksheet, nCount As Long, n As Long, oObj() As String, oFolder _
        , oCurrApp As Application, oCurrBook As Workbook, oCurrSheet As Worksheet, oCurrRange As Range _
        , oTmpApp As Application, oTmpBook As Workbook, oTmpSheet As Worksheet, oTmpRange As Range _
        , cSheetName As String, cKeyColumn As String, cFirstColumn As String, cLastColumn As String _
        , cEndValue As String, oRange As Range, nEndRow As Long, nRow As Long, cCurrKey As String _
        , nCol As Long, bError As Boolean

    On Error GoTo ErrMsg
    bError = False
    
    If VBA.Val(Application.Version) < 9 Then Exit Sub

    Set oCurrApp = Application
    Set oCurrBook = oCurrApp.ActiveWorkbook
    Set oObjSheet = oCurrBook.ActiveSheet
    nCount = VBA.Val(ScriptGet(oObjSheet, "obj_count"))
    If nCount = 0 Then Exit Sub
    
    oFolder = oCurrApp.GetOpenFilename( _
        FileFilter:="Книга Microsoft Office Excel,*.xls", _
        Title:="Выберите файл")

    If oFolder = False Then
        Call VBA.MsgBox("Экспорт данных в другой файл не выполнен." _
            + VBA.vbNewLine + "Не указана книга Microsoft Office Excel." _
            , VBA.vbOKOnly + VBA.vbExclamation, "Внимание")
        Exit Sub
    End If
    
    If oFolder = oCurrBook.FullName Then
        Call VBA.MsgBox("Экспорт данных в другой файл не выполнен." _
            + VBA.vbNewLine + "Указана текущая книга Microsoft Office Excel." _
            , VBA.vbOKOnly + VBA.vbExclamation, "Внимание")
        Exit Sub
    End If
    
    Call SecurityLevelSet(True)
    
    Set oTmpApp = CreateObject("Excel.Application")
    oTmpApp.Visible = False
    oTmpApp.DisplayAlerts = False
    oTmpApp.ScreenUpdating = False
    
    oTmpApp.Workbooks.Open (oFolder)
    Set oTmpBook = oTmpApp.Workbooks(1)
    
    For n = 1 To nCount
        oObj = VBA.Split(ScriptGet(oObjSheet, "obj_" + VBA.Trim(VBA.Str(n))), "#")
        If UBound(oObj) = 4 Then
            cSheetName = oObj(0)
            cKeyColumn = oObj(1)
            cFirstColumn = oObj(2)
            cLastColumn = oObj(3)
            cEndValue = oObj(4)
            
            Set oCurrSheet = SheetGet(oCurrBook, cSheetName, False)
            Set oTmpSheet = SheetGet(oTmpBook, cSheetName, False)
            
            If Not oCurrSheet Is Nothing And Not oTmpSheet Is Nothing Then
                Set oCurrRange = oCurrSheet.Columns(cKeyColumn)
                Set oRange = oCurrRange.Find(cEndValue, LookIn:=xlValues)
                If Not oRange Is Nothing Then
                    nEndRow = oRange.Row
                Else
                    nEndRow = oCurrRange.Rows.Count
                End If
            
                Set oTmpRange = oTmpSheet.Columns(cKeyColumn)
                For nRow = 1 To nEndRow
                    oCurrApp.StatusBar = "Обработка листа [" + cSheetName + "]: " _
                        + VBA.Trim(VBA.Str(VBA.CInt(nRow * 100 / nEndRow))) + "%"
                    
                    cCurrKey = VBA.Trim(VBA.CStr(oCurrSheet.Range(cKeyColumn & nRow).Value))
                    If cCurrKey <> "" Then
                        Set oRange = oTmpRange.Find(cCurrKey, LookIn:=xlValues)
                        If Not oRange Is Nothing Then
                            For nCol = oCurrSheet.Range(cFirstColumn & nRow).Column To oCurrSheet.Range(cLastColumn & nRow).Column
                                If Not oTmpSheet.Cells(oRange.Row, nCol).Locked Then
                                    oTmpSheet.Cells(oRange.Row, nCol).Value = oCurrSheet.Cells(nRow, nCol).Value
                                End If
                            Next nCol
                        End If
                    End If
                Next nRow
            End If
        End If
    Next n
    
ExitSub:
    If Not oTmpBook Is Nothing Then
        oTmpBook.Save
        oTmpBook.Saved = True
        oTmpBook.Close SaveChanges:=False
        Set oTmpBook = Nothing
    End If
    
    If Not oTmpApp Is Nothing Then
        oTmpApp.Quit
        Set oTmpApp = Nothing
    End If
    
    Call SecurityLevelSet(False)
    oCurrApp.StatusBar = ""
    
    If Not bError Then
        n = VBA.MsgBox("Экспорт данных в файл " + oFolder + " успешно завершен." _
                + VBA.vbNewLine + "Открыть этот файл?" _
                , VBA.vbYesNo + VBA.vbInformation, "Внимание")
        If n = 6 Then
            oCurrApp.Workbooks.Open (oFolder)
        End If
    End If
    Exit Sub
    
ErrMsg:
    Call VBA.MsgBox("Номер: " + VBA.Str(Err.Number) + VBA.vbNewLine _
        + "Источник: " + Err.Source + VBA.vbNewLine _
        + "Описание: " + Err.Description, VBA.vbOKOnly + VBA.vbCritical, "Ошибка")
    bError = True
    GoTo ExitSub
End Sub
'Пример: Call InitRroMenu("субъекты РФ,E,F,Y,END;МСУ,E,F,Y,END")
Public Sub InitRroMenu(cInitStr As String)
    Dim bFound As Boolean, oCBar As Object, oInit() As String, n As Long, oSheet As Worksheet

    If VBA.Val(Application.Version) < 9 Then Exit Sub
    
    oInit = VBA.Split(VBA.Trim(cInitStr), ";")
    
    For Each oSheet In Application.ActiveWorkbook.Sheets
        Call ScriptSet(oSheet, "obj_count", VBA.Trim(VBA.Str(UBound(oInit) + 1)))
        For n = 0 To UBound(oInit)
            Call ScriptSet(oSheet, "obj_" + VBA.Trim(VBA.Str(n + 1)), VBA.Trim(oInit(n)))
        Next n
    Next oSheet
    
    bFound = False
    For Each oCBar In Application.CommandBars
        If oCBar.Name = "RRO_MENU" Then bFound = True
    Next
    If bFound Then Application.CommandBars("RRO_MENU").Delete

    Set oCBar = CommandBars.Add("RRO_MENU", 1)
    With oCBar.Controls.Add(Type:=msoControlButton)
        .FaceId = 142
        .Style = msoButtonIcon
        .Caption = "Экспортировать данные в другой файл"
        .OnAction = "ExportSheetData"
    End With

    oCBar.Enabled = True
    oCBar.Visible = True
    Application.ThisWorkbook.Saved = True
End Sub
Sub RegistryDelValue(hKey As Long, strPath As String, strValue As String)
    Dim Ret
    
    RegCreateKey hKey, strPath, Ret
    RegDeleteValue Ret, strValue
    RegCloseKey Ret
End Sub
Function RegistryGetValue(hKey As Long, strPath As String, strValue As String)
    Dim Ret, lResult As Long, lValueType As Long, strBuf As String, lBufSize As Long, strData As Long, lType As Long
    
    RegOpenKey hKey, strPath, Ret
    lResult = RegQueryValueEx(Ret, strValue, 0, lType, ByVal 0, lBufSize)
    If lResult = 0 Then
        Select Case lType
        Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ, REG_BINARY
            strBuf = VBA.String(lBufSize, VBA.Chr$(0))
            lResult = RegQueryValueEx(Ret, strValue, 0, 0, ByVal strBuf, lBufSize)
            If lResult = 0 Then
                If VBA.InStr(1, strBuf, VBA.Chr$(0)) > 0 Then
                    RegistryGetValue = VBA.Left$(strBuf, VBA.InStr(1, strBuf, VBA.Chr$(0)) - 1)
                Else
                    RegistryGetValue = strBuf
                End If
            End If
        
        Case REG_DWORD
            lResult = RegQueryValueEx(Ret, strValue, 0, 0, strData, lBufSize)
            If lResult = 0 Then
                RegistryGetValue = strData
            End If
        End Select
    End If
    RegCloseKey Ret
End Function
Sub RegistrySetValue(hKey As Long, strPath As String, strValue As String, strData As String, lType As Long)
    Dim Ret, lData As Long
    
    RegCreateKey hKey, strPath, Ret
    Select Case lType
    Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ, REG_BINARY
        RegSetValueEx Ret, strValue, 0, lType, ByVal strData, VBA.Len(strData)
    Case REG_DWORD
        lData = VBA.Val(strData)
        RegSetValueEx Ret, strValue, 0, lType, lData, 4
    End Select
    RegCloseKey Ret
End Sub
Sub SecurityLevelSet(ByVal bSetOn As Boolean)
    Dim cVersion As String, cPropName As String, cPropValue As String
    
    cVersion = VBA.Trim(Application.Version)
    If VBA.Val(cVersion) < 9 Then Exit Sub
    
    cPropName = VBA.IIf(VBA.Val(cVersion) >= 12, "VBAWarnings", "Level")
    cPropValue = VBA.IIf(bSetOn, "3", "1")

    Call RegistrySetValue(HKEY_CURRENT_USER, "Software\Microsoft\Office\" + cVersion + "\Excel\Security", cPropName, cPropValue, REG_DWORD)
End Sub
Function ScriptExists(ByVal oSheet As Worksheet, ByVal cIDScript As String) As Boolean
    Dim bRes As Boolean, n As Long
    
    bRes = False
    cIDScript = VBA.Trim(cIDScript)
    
    For n = 1 To oSheet.Scripts.Count
        If VBA.UCase(VBA.Trim(oSheet.Scripts(n).ID)) = VBA.UCase(VBA.Trim(cIDScript)) Then
            bRes = True
        End If
    Next n
    
    ScriptExists = bRes
End Function
Function ScriptGet(ByVal oSheet As Worksheet, ByVal cIDScript As String) As String
    Dim cRes As String

    cRes = ""
    cIDScript = VBA.Trim(cIDScript)
    
    If ScriptExists(oSheet, cIDScript) Then
        cRes = VBA.Trim(oSheet.Scripts(cIDScript).ScriptText)
    End If
    
    ScriptGet = cRes
End Function
Sub ScriptSet(ByVal oSheet As Worksheet, ByVal cIDScript As String, ByVal cValueScript As String)
    cIDScript = VBA.Trim(cIDScript)
    cValueScript = VBA.Trim(cValueScript)

    If Not ScriptExists(oSheet, cIDScript) Then
        oSheet.Scripts.Add Location:=2, Language:=2, ID:=cIDScript, ScriptText:=cValueScript
    Else
        oSheet.Scripts(cIDScript).ScriptText = cValueScript
    End If
End Sub
Function SheetGet(oBook As Workbook, cNameSheet As String, Optional ByVal bFull As Boolean = True) As Worksheet
    Dim oSheet As Worksheet, oSheetRet As Worksheet
    
    Set oSheetRet = Nothing
    
    For Each oSheet In oBook.Sheets
        If oSheet.Name = cNameSheet And bFull Then
            Set oSheetRet = oSheet
            Exit For
        End If
    
        If VBA.InStr(oSheet.Name, cNameSheet) > 0 And Not bFull Then
            Set oSheetRet = oSheet
            Exit For
        End If
    Next oSheet
    
    Set SheetGet = oSheetRet
End Function
