Is it possible to implement an export/import feature for the unlocked cells in my Excel file? (Through VBA?)

[Rnkhch]

Hello,

I have made an Excel application, with protected worksheets and workbook, that I have updated and improved over the last several months, and it continues to evolve as I add more features and code as the need arises. One issue though is that each time I make an updated version, I have to manually copy/paste the data from all unlocked segments into the new file.

I'm hoping that it would be possible to implement an export/import feature in my application such that I would press an export button that would save the unlocked data in a file (perhaps through a "save as" window", and then I would press an import button and select the saved data (perhaps through an "open" window) and have all the data be populated in the correct cells.

If possible, it would be fabulous, and I would highly appreciate the help from the VBA experts here

 

[Alex Blakenburg]

If the Export didn't work even without it being protected, I need more information on what happened.
Did you F8 through it to see what it did ? I take it that it didn't error out.

 

[Alex Blakenburg]

Here is the revised Export & Import macro, the Export will loop through the 3 sheet, the import will handle it based on the sheet name in the export.

1) The Export Macro has 3 lines in it relating to the password currently commented out
You really shouldn't need to uncomment them since it works fine for me with the sheet protected.
If you do need to activate those 3 lines search for "pwd"

2) The Export doesn't work and its not password related doesn't give me any information to trouble shoot it.
If it is erroring out then show me the error dialogue box and what line is hightlighted when you go into Debug mode.
If it is not erroring out F8 through the code and tell me what it is doing.

Here is my protection setting and it works fine so there has to be something else going on.

Sub ExportData()

    Dim wbCurrent As Workbook, wbExport As Workbook
    Dim wsCurrent As Worksheet, wsExportMain As Worksheet
    Dim rngCurrent As Range
    Dim cellUnlock As Range
    Dim arrUnlock As Variant
    Dim i As Long
    Dim FirstCell As Range
    Dim CurrCell As Range
    Dim ExportDateTime As Date
    Dim fnameFull As String, ExportFName As String
    Dim arrShtNames As Variant, ShtName As Variant
    
    Dim startTime As Double
    startTime = Timer

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wbCurrent = ThisWorkbook
    fnameFull = wbCurrent.FullName
    arrShtNames = Array("Comments", "Info-Setup", "Plates-Input")

    ReDim arrUnlock(1 To 100000, 1 To 1)
        
    With Application.FindFormat
        .Clear
        .Locked = False
    End With
    
    Dim pwd As String
    'pwd = "Test"
    
    For Each ShtName In arrShtNames
    
        Set wsCurrent = wbCurrent.Worksheets(ShtName)
        Set rngCurrent = wsCurrent.UsedRange
        'wsCurrent.Unprotect Password:=pwd
    
        With rngCurrent
            Set FirstCell = .Cells.Find(What:="", After:=.Cells(1, 1), _
                                LookIn:=xlFormulas, LookAt:=xlPart, _
                                SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                MatchCase:=False, SearchFormat:=True)
        End With
    
        If Not FirstCell Is Nothing Then
            Set CurrCell = FirstCell
            ' First row in output array
            If i = 0 Then
                i = i + 1
                ExportDateTime = Now
                arrUnlock(i, 1) = "Export Run: " & ExportDateTime
            End If
    
            Do
                i = i + 1
                With CurrCell
                    arrUnlock(i, 1) = .Parent.Name & "~" & .Address(0, 0, 1, 0) & "~" & .Formula
                End With
    
                Set CurrCell = rngCurrent.Cells.Find(What:="", After:=CurrCell, _
                    LookIn:=xlFormulas, LookAt:=xlPart, _
                    SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=True)
            Loop Until CurrCell.Address = FirstCell.Address
        End If
        
        'wsCurrent.Protect Password:=pwd
    Next ShtName
    
    If i > 1 Then
        arrUnlock(1, 1) = arrUnlock(1, 1) & " ~ No of Cells: " & i - 1
        
        ' Output Export Array
        Set wbExport = Workbooks.Add(xlWBATWorksheet)
        Set wsExportMain = ActiveSheet
        
        With wsExportMain
            .Range("A1").Resize(i).Value = arrUnlock
            .Columns(1).AutoFit
        End With
        
        With wbExport
            ExportFName = Left(fnameFull, InStrRev(fnameFull, ".") - 1) & Format(ExportDateTime, "_yyyymmdd_hhmmss") & ".csv"
            .SaveAs FileName:=ExportFName, FileFormat:=xlCSV
            .Saved = True
            .Close
        End With
    End If

      
    Application.FindFormat.Clear
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "Duration in seconds: " & Timer - startTime
End Sub

Sub ImportData()

    Dim wbCurrent As Workbook, wbImport As Workbook
    Dim wsImportMain As Worksheet
    Dim rngImport As Range
    Dim i As Long
    Dim fnameImport As String
    Dim cellImport As Variant
    Dim rCell As Variant
    
    Dim startTime As Double
    startTime = Timer
    
    Set wbCurrent = ThisWorkbook
     
    fnameImport = Application.GetOpenFilename(FileFilter:="CSV Files,*.csv", Title:="Select file to import", MultiSelect:=False)
    If fnameImport = "False" Then
        MsgBox "No file selected, exiting macro"
        GoTo CleanExit
    End If
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wbImport = Workbooks.Open(FileName:=fnameImport, ReadOnly:=True)
    Set wsImportMain = ActiveSheet
    Set rngImport = wsImportMain.Range("A1").CurrentRegion.Columns(1)
    Set rngImport = rngImport.Resize(rngImport.Rows.Count - 1).Offset(1)    ' Exclude header in A1
       
    For Each rCell In rngImport.Cells
        ' format = sheetname ~ cell address ~ cell content
        cellImport = Split(rCell.Value, "~")
        With wbCurrent
            .Worksheets(cellImport(0)).Range(cellImport(1)).Formula = cellImport(2)
        End With
    Next rCell
    
    wbImport.Close SaveChanges:=False
    MsgBox "Duration in seconds: " & Timer - startTime
    
CleanExit:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

 

[Rnkhch]

Success!!! It worked with all three sheets protected, when I deleted all the codes (for this function and others) and rewrote all the codes again. Not sure what actually changed because as far as I could see, all the codes were the same before and after. I left both "select locked cells" and "select unlocked cells" checked. Thanks much

Couple of little enhancements:
1. Could you shorten the timers' significant digits to only 2, so they would show something like 5.17 instead of 5.17652375
2. I changed the import message to "Data import completed successfully! ( x.xx seconds)". By any chance, would it be possible to actually check if the process was "successful" or not? i.e. to count the total number of unlocked cells that are going to be transported to the csv file and compare it to the total number of available unlocked cells, and if they are not equal, show a different message.

Thanks much!

 

[Rnkhch]

Sorry I meant "Data export ..." in #2 above

 

[Rnkhch]

By the way, I ran into the same trouble as before, when I tried to apply the code to my other larger file. I noticed that it only export one cell of Plates-Input which is F3 and for whatever reason it doesn't see all the other thousands of unlocked cells

I made another post for this issue, so I thought to let you know here: Why VBA macro doesn't work on certain protected sheets?

Also regarding your previous questions:

If it is erroring out then show me the error dialogue box and what line is hightlighted when you go into Debug mode.

No errors come up. I get the final pop-up saying the time.

If it is not erroring out F8 through the code and tell me what it is doing

I tried F8ing, but I get stuck in this loop:

i = i + 1
                With CurrCell
                    arrUnlock(i, 1) = .Parent.Name & "~" & .Address(0, 0, 1, 0) & "~" & .Formula
                End With
    
                Set CurrCell = rngCurrent.Cells.Find(What:="", After:=CurrCell, _
                    LookIn:=xlFormulas, LookAt:=xlPart, _
                    SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=True)
            Loop Until CurrCell.Address = FirstCell.Address

Please let me know what other information I can get for you to help you solve this mystery.

Thank you so much

 

[Alex Blakenburg]

I have responded on your new thread.

 

[Rnkhch]

Thank you! So I was mysteriously able to get the larger file to work as well (which I described on the other thread).

So hopefully, when you get a chance, you can implement those enhancement that I mentioned before, plus one more? I'm gonna paste them below and correct the typo and add the third one:

1. Could you shorten the timers' significant digits to only 2, so they would show something like 5.17 instead of 5.17652375
2. I changed the export message to "Data export completed successfully! ( x.xx seconds)". By any chance, would it be possible to actually check if the process was "successful" or not? i.e. to count the total number of unlocked cells (identified by the VBA loop) that are going to be transported to the csv file and compare it to the total number of available unlocked cells, and if they are not equal, show a different message.
3. Would it be possible to add the option to open a Save As window upon clicking Export so the users can choose where to save the csv file?

Thank you so much!!

 

[Alex Blakenburg]

1. Could you shorten the timers' significant digits to only 2, so they would show something like 5.17 instead of 5.17652375
• Sure - I had only intended for that message box to be shown while testing since time taken as a concern but simply change the msgbox output in both procedures to something like this:

MsgBox "Duration in seconds: " & Format(Timer - startTime, "0.00")

2. I changed the export message to "Data export completed successfully! ( x.xx seconds)". By any chance, would it be possible to actually check if the process was "successful" or not? i.e. to count the total number of unlocked cells (identified by the VBA loop) that are going to be transported to the csv file and compare it to the total number of available unlocked cells, and if they are not equal, show a different message.
• No
Unfortunately the only way to count total number of unlocked cells is to perform the same loop that is being performed by the export. It would be counter productive to run the same loop twice doubling the run time with the chances of them coming up with a different number being slim to none. (in fact it would be really odd for them to be different)

3. Would it be possible to add the option to open a Save As window upon clicking Export so the users can choose where to save the csv file?
• Done in the below code

Sub ExportData_V02()

    Dim wbCurrent As Workbook, wbExport As Workbook
    Dim wsCurrent As Worksheet, wsExportMain As Worksheet
    Dim rngCurrent As Range
    Dim cellUnlock As Range
    Dim arrUnlock As Variant
    Dim i As Long
    Dim FirstCell As Range
    Dim CurrCell As Range
    Dim ExportDateTime As Date
    Dim fnameFull As String, ExportFName As String
    Dim arrShtNames As Variant, ShtName As Variant
    
    Dim startTime As Double
    startTime = Timer

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wbCurrent = ThisWorkbook
    fnameFull = wbCurrent.FullName
    arrShtNames = Array("Comments", "Info-Setup", "Plates-Input")

    ReDim arrUnlock(1 To 100000, 1 To 1)
        
    With Application.FindFormat
        .Clear
        .Locked = False
    End With
    
    Dim pwd As String
    'pwd = "Test"
    
    For Each ShtName In arrShtNames
    
        Set wsCurrent = wbCurrent.Worksheets(ShtName)
        Set rngCurrent = wsCurrent.UsedRange
        'wsCurrent.Unprotect Password:=pwd
    
        With rngCurrent
            Set FirstCell = .Cells.Find(What:="", After:=.Cells(1, 1), _
                                LookIn:=xlFormulas, LookAt:=xlPart, _
                                SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                MatchCase:=False, SearchFormat:=True)
        End With
    
        If Not FirstCell Is Nothing Then
            Set CurrCell = FirstCell
            ' First row in output array
            If i = 0 Then
                i = i + 1
                ExportDateTime = Now
                arrUnlock(i, 1) = "Export Run: " & ExportDateTime
            End If
    
            Do
                i = i + 1
                With CurrCell
                    arrUnlock(i, 1) = .Parent.Name & "~" & .Address(0, 0, 1, 0) & "~" & .Formula
                End With
    
                Set CurrCell = rngCurrent.Cells.Find(What:="", After:=CurrCell, _
                    LookIn:=xlFormulas, LookAt:=xlPart, _
                    SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=True)
            Loop Until CurrCell.Address = FirstCell.Address
        End If
        
        'wsCurrent.Protect Password:=pwd
    Next ShtName
    
    If i > 1 Then
        arrUnlock(1, 1) = arrUnlock(1, 1) & " ~ No of Cells: " & i - 1
        
        ' Output Export Array
        Set wbExport = Workbooks.Add(xlWBATWorksheet)
        Set wsExportMain = ActiveSheet
        
        With wsExportMain
            .Range("A1").Resize(i).Value = arrUnlock
            .Columns(1).AutoFit
        End With
        
        Dim FldrPicker As FileDialog
        Dim myFolder As String
        
        Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
        
        With FldrPicker
            .Title = "Select A Export Folder"
            .AllowMultiSelect = False
            If .Show <> -1 Then Exit Sub 'Check if user clicked cancel button
            myFolder = .SelectedItems(1) & "\"
        End With
            
        With wbExport
            'ExportFName = Left(fnameFull, InStrRev(fnameFull, ".") - 1) & Format(ExportDateTime, "_yyyymmdd_hhmmss") & ".csv"
            ExportFName = myFolder & Left(wbCurrent.Name, InStrRev(wbCurrent.Name, ".") - 1) & Format(ExportDateTime, "_yyyymmdd_hhmmss") & ".csv"
            .SaveAs FileName:=ExportFName, FileFormat:=xlCSV
            .Saved = True
            .Close
        End With
    End If

      
    Application.FindFormat.Clear
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    Dim msg As String
    msg = "Data export completed successfully! ( " & Format(Timer - startTime, "0.00") & " seconds)"
    MsgBox msg

End Sub

Sub ImportData_v02()

    Dim wbCurrent As Workbook, wbImport As Workbook
    Dim wsImportMain As Worksheet
    Dim rngImport As Range
    Dim i As Long
    Dim fnameImport As String
    Dim cellImport As Variant
    Dim rCell As Variant
    
    Dim startTime As Double
    startTime = Timer
    
    Set wbCurrent = ThisWorkbook
     
    fnameImport = Application.GetOpenFilename(FileFilter:="CSV Files,*.csv", Title:="Select file to import", MultiSelect:=False)
    If fnameImport = "False" Then
        MsgBox "No file selected, exiting macro"
        GoTo CleanExit
    End If
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wbImport = Workbooks.Open(FileName:=fnameImport, ReadOnly:=True)
    Set wsImportMain = ActiveSheet
    Set rngImport = wsImportMain.Range("A1").CurrentRegion.Columns(1)
    Set rngImport = rngImport.Resize(rngImport.Rows.Count - 1).Offset(1)    ' Exclude header in A1
       
    For Each rCell In rngImport.Cells
        ' format = sheetname ~ cell address ~ cell content
        cellImport = Split(rCell.Value, "~")
        With wbCurrent
            .Worksheets(cellImport(0)).Range(cellImport(1)).Formula = cellImport(2)
        End With
    Next rCell
    
    wbImport.Close SaveChanges:=False

    Dim msg As String
    msg = "Data import completed successfully! ( " & Format(Timer - startTime, "0.00") & " seconds)"
    MsgBox msg
    
CleanExit:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

 

[Rnkhch]

This is superb and working really well And my applications are now so much better with the Export/Import feature! I rolled out both of my project files a bit ago

Thanks much for all your help!

 

[Alex Blakenburg]

No problem. Thanks for the feedback and glad I could help.