VBA code to get selected range to another sheet

[RAJESH1960]

Hello Code experts,

I will make it very simple to explain. Column E6 till end in List of Ledgers Sheet is blank. Column B2 to end is also blank in Master Data sheet.

I need to get from pastedata sheet all names below the “particulars” column till end excluding grand total to cell E6 of List of Ledgers sheet.

The names in column E where cells in column F rows contain NA to be copied to MasterData sheet to cell B2 and remove duplicates. This I will aprrecaite any help to do it with the help of a code.

Please note: I have entered manually and colored the columns in both the sheets. These entries should display with the help of a code.
Query Code to get Ledger names from another sheet.xlsx
The Particulars column is always in column 2 and the row of Particulars (Heading) column (in this case it is the 7th row) is not fixed. It may change depending on the number of lines of address in different companies. Even if this company edits the address which is very rare, it may change accordingly.

 

[RAJESH1960]

I have recorded the macro to understand the steps involved. I have no advance knowledge of coding to select the selected ranges in the code.

Sub RecordedMacro()
'
' Macro2 Macro
'

'
    Sheets("PasteData").Select
    ActiveWindow.SmallScroll Down:=-21
    Range("B8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range("B8:B36").Select
    Selection.Copy
    ActiveSheet.Previous.Select        'List of ledgers sheet
    ActiveSheet.Paste
    Range("E6:F6").Select
    Range("F6").Activate
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("List of Ledgers").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("List of Ledgers").Sort.SortFields.Add2 Key:=Range( _
        "F6:F34"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("List of Ledgers").Sort
        .SetRange Range("E6:F34")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("E6:E22").Select
    Selection.Copy
    Sheets("MasterData").Select
    Range("B2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("$B$1:$B$18").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("B2").Select
End Sub

 

[johnnyL]

How about:

Sub MoveDataToDifferentSheets()
'
    Application.ScreenUpdating = False                                                              ' Turn ScreenUpdating off
'
    Dim StartTime                           As Single
    StartTime = Timer                                                                               ' Start the stop watch
'
    Dim DictionaryRow                       As Long
    Dim SourceHeaderColumnNumber            As Long, SourceHeaderRow                    As Long, SourceLastRow  As Long
    Dim cell                                As Range
    Dim CodeCompletionTime                  As Single
    Dim SourceLastColumnLetter              As String
    Dim DataDictionary                      As Variant
    Dim List_of_LedgersFormulasColumnArray  As Variant, PasteDataParticularsDataArray   As Variant
    Dim SourceWS                            As Worksheet
'
    Set SourceWS = Sheets("PasteData")                                                               ' <--- Set this to the source sheet
'
    SourceLastColumnLetter = Split(Cells(1, (SourceWS.Cells.Find("*", , xlFormulas, , _
            xlByColumns, xlPrevious).Column)).Address, "$")(1)                                      ' Get last column letter used in the source sheet
    SourceLastRow = SourceWS.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row - 1          ' Get the last source row of data minus the total row
'
    With SourceWS.Range("A1:" & SourceLastColumnLetter & SourceLastRow)                             ' Look through the source sheet for the header row
        Set cell = .Find("Particulars", LookIn:=xlValues)                                           '   Find the header called 'Particulars'
'
        If Not cell Is Nothing Then                                                                 '   If 'Particulars' is found then ...
            SourceHeaderRow = cell.Row                                                              '       Save the row # into SourceHeaderRow
            SourceHeaderColumnNumber = cell.Column                                                              '       Save the Column # into SourceHeaderColumn
        End If
    End With
'
    PasteDataParticularsDataArray = SourceWS.Range(SourceWS.Cells(SourceHeaderRow + 1, SourceHeaderColumnNumber), _
            SourceWS.Cells(SourceLastRow, SourceHeaderColumnNumber))                        ' Save Data to be pasted into 2D 1 Based PasteDataParticularsDataArray
'
    Sheets("List of Ledgers").Range("E6").Resize(UBound(PasteDataParticularsDataArray, _
            1)) = PasteDataParticularsDataArray                                             'Display PasteDataParticularsDataArray to Sheets("List of Ledgers")
'
    List_of_LedgersFormulasColumnArray = Sheets("List of Ledgers").Range("F6:F" & SourceLastRow)    ' Load formula column from Sheets("List of Ledgers") to array
'
    DataDictionary = Sheets("List of Ledgers").Range("E6", Sheets("List of Ledgers").Cells(Rows.Count, "F").End(xlUp))  '   Create DataDictionary
'
    With CreateObject("Scripting.Dictionary")
        For DictionaryRow = 1 To UBound(DataDictionary)                                                                 ' Loop through each row of DataDictionary
            If Not .Exists(DataDictionary(DictionaryRow, 1)) And IsError(List_of_LedgersFormulasColumnArray(DictionaryRow, 1)) Then ' If uniue value found &  ...
'                                                                                                                       ' Error found in column to the right then ...
                .Add DataDictionary(DictionaryRow, 1), Array(DataDictionary(DictionaryRow, 2))                          ' add unique value to DataDictionary
            End If
        Next                                                                                                            ' Loop back
'
        Sheets("MasterData").Range("B2").Resize(.Count) = Application.Transpose(.keys)                              ' Display unique values on Sheets("MasterData")
    End With
'
    Application.ScreenUpdating = True                                                                               ' Turn ScreenUpdating back on
'
    CodeCompletionTime = Timer - StartTime                                                                          ' Stop the stop watch
    CodeCompletionTime = Format(CodeCompletionTime, ".#####")                                                       ' Prevent scientific notation results
    Debug.Print "Time to complete MoveDataToDifferentSheets = " & CodeCompletionTime & " seconds."                  ' Display the time elapsed to the user (Ctrl-G)
'
    Application.Speech.Speak "This code completed in, , , " & CodeCompletionTime & " seconds."                      ' Provide audio result
End Sub

 

[RAJESH1960]

It's MAGIC. JohnnyL. It is as expected (perfect). Thanks a lot.

 

[RAJESH1960]

The explanation to each line of code is just great. It will help me to understand better if I will have to edit or use the code in another app. it will be so easy. Thanks for that too JohnnyL.?

 

[johnnyL]

Glad to help @RAJESH1960.

 

[johnnyL]

By the way, if you want to clear out the old data prior to running the script, you could try something like the following placed after the 'Dim' lines at the top of the script:

    Sheets("MasterData").Range("B2", Sheets("MasterData").Range("B2").End(xlDown)).ClearContents
    Sheets("List of Ledgers").Columns("E:E").ClearContents

 

[RAJESH1960]

Yeah. I noticed when I tried with another data. I will just add these lines and check again.

 

[RAJESH1960]

It's working perfect now with the next data too.