Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people, just like you, are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
SolvedPrivate

VBA: copy Range dynamically by calling a function or a procedure v2

Posted on 2016-08-12
8
49 Views
Last Modified: 2016-08-26
Hello experts,

I have the following procedure available at:


Sub CopyRangeDynamically()

    Dim wsConfig As Worksheet, wsDestination As Worksheet, wsSourceSheet As Worksheet
    Dim sSheetName As String, sSourceColumn As String, sSourceColumn2 As String, sDestinationColumn, sSheetName2 As String
    Dim rgDestination As Range, rgSource As Range
    Dim rw As Integer, MaxRowSourceSheet As Long

    CheckConfigSheet
    
    Set wsConfig = Worksheets("4.Parameter-Copy-Range")
    Application.ScreenUpdating = False
    For rw = 2 To wsConfig.Range("A1").CurrentRegion.Rows.Count
        sSheetName = wsConfig.Range("A" & rw) '==Original Sheet Name
        Set wsSourceSheet = Worksheets(sSheetName)
        sSheetName2 = wsConfig.Range("D" & rw) '==Destination Sheet Name
        Set wsDestination = Worksheets(sSheetName2)
        MaxRowSourceSheet = wsSourceSheet.Cells.SpecialCells(xlCellTypeLastCell).Row '==Max Row Original Sheet
        sSourceColumn = wsConfig.Range("B" & rw)
        sSourceColumn2 = wsConfig.Range("C" & rw)
        sDestinationColumn = wsConfig.Range("E" & rw)
        sDestinationHeader = wsConfig.Range("F" & rw)
        'MatchCount = 0
        'wsSourceSheet.Select
        Set rgSource = wsSourceSheet.Range(sSourceColumn & "2:" & sSourceColumn2 & MaxRowSourceSheet)
        Set rgDestination = wsDestination.Range(sDestinationColumn & "2")
        rgSource.Copy
        rgDestination.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False ' to clear the clipboard
        wsDestination.Range(sDestinationColumn & "1").Value = sDestinationHeader
    Next
    MsgBox "Process has been done", vbOKOnly 'just as an FYI to the user and pass back control
       
    wsConfig.Select
End Sub


Sub CheckConfigSheet()
    Dim wsConfig As Worksheet, ws As Worksheet, rw As Integer, col As Integer, i As Integer, WarningText As String
    Set wsConfig = Worksheets("4.Parameter-Copy-Range")
    For rw = 2 To wsConfig.Range("A1").CurrentRegion.Rows.Count
        i = 0
        For Each ws In Worksheets
            If wsConfig.Range("A" & rw) <> "" Then
                If UCase(ws.Name) = UCase(wsConfig.Range("A" & rw)) Then
                    i = i + 1
                End If
                If UCase(ws.Name) = UCase(wsConfig.Range("D" & rw)) Then
                    i = i + 1
                End If
            End If
        Next ws
        For col = 2 To 3
            If wsConfig.Cells(rw, col) <> "" And Len(wsConfig.Cells(rw, col)) <= 2 Then
                If WorksheetFunction.IsText(wsConfig.Cells(rw, col)) Then
                    i = i + 1
                End If
            End If
        Next col
        If wsConfig.Cells(rw, col) <> "" And Len(wsConfig.Cells(rw, col)) <= 2 Then
            If WorksheetFunction.IsText(wsConfig.Cells(rw, 4)) Then
                i = i + 1
            End If
        End If
        'If wsConfig.Range("G" & rw) = 0 Or wsConfig.Range("G" & rw) = 1 Then
            'i = i + 1
        'End If
        If i <> 4 Then
            WarningText = "Warning" & Chr(10) & "Data entered in Config Sheet row " & CStr(rw) & " is not consistent, please check that:"
            WarningText = WarningText & Chr(10) & "1-Sheets exist or there is a misspelled mistake or you haven't entered data."
            WarningText = WarningText & Chr(10) & "2-Required columns entered in Range are alphabetical and not numeric."
            WarningText = WarningText & Chr(10) & "3-Required flag value is not 0 or 1"
            WarningText = WarningText & Chr(10) & Chr(10) & "Program stop"
            MsgBox WarningText, vbCritical
            End
        End If
    Next rw
End Sub

Open in new window



In order to copy range dinamically based on the folling configuration file:

2016-08-12-10_04_14-Microsoft-Excel-.png

The problem that I am facing is that the reported the destination range located in the destination sheet is not clear previously before performing the copy process. I would like to correct the procedure in order to clear previsouly the range reported Destination Sheet & Destination Letter and then performing the copy process.

Thank you again for your help.
0
Comment
Question by:LD16
  • 3
  • 2
  • 2
8 Comments
 
LVL 50

Expert Comment

by:Rgonzo1971
ID: 41753495
Hi,

pls try

Sub CopyRangeDynamically()

    Dim wsConfig As Worksheet, wsDestination As Worksheet, wsSourceSheet As Worksheet
    Dim sSheetName As String, sSourceColumn As String, sSourceColumn2 As String, sDestinationColumn, sSheetName2 As String
    Dim rgDestination As Range, rgSource As Range
    Dim rw As Integer, MaxRowSourceSheet As Long

    CheckConfigSheet
    
    Set wsConfig = Worksheets("4.Parameter-Copy-Range")
    Application.ScreenUpdating = False
    For rw = 2 To wsConfig.Range("A1").CurrentRegion.Rows.Count
        sSheetName = wsConfig.Range("A" & rw) '==Original Sheet Name
        Set wsSourceSheet = Worksheets(sSheetName)
        sSheetName2 = wsConfig.Range("D" & rw) '==Destination Sheet Name
        Set wsDestination = Worksheets(sSheetName2)
        MaxRowSourceSheet = wsSourceSheet.Cells.SpecialCells(xlCellTypeLastCell).Row '==Max Row Original Sheet
        sSourceColumn = wsConfig.Range("B" & rw)
        sSourceColumn2 = wsConfig.Range("C" & rw)
        sDestinationColumn = wsConfig.Range("E" & rw)
        sDestinationHeader = wsConfig.Range("F" & rw)
        'MatchCount = 0
        'wsSourceSheet.Select
        Set rgSource = wsSourceSheet.Range(sSourceColumn & "2:" & sSourceColumn2 & MaxRowSourceSheet)
        Set rgDestination = wsDestination.Range(sDestinationColumn & "2")
        rgSource.Copy
        rgDestination.Resize(Rows.Count - 2).ClearContents
        rgDestination.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False ' to clear the clipboard
        wsDestination.Range(sDestinationColumn & "1").Value = sDestinationHeader
    Next
    MsgBox "Process has been done", vbOKOnly 'just as an FYI to the user and pass back control
       
    wsConfig.Select
End Sub


Sub CheckConfigSheet()
    Dim wsConfig As Worksheet, ws As Worksheet, rw As Integer, col As Integer, i As Integer, WarningText As String
    Set wsConfig = Worksheets("4.Parameter-Copy-Range")
    For rw = 2 To wsConfig.Range("A1").CurrentRegion.Rows.Count
        i = 0
        For Each ws In Worksheets
            If wsConfig.Range("A" & rw) <> "" Then
                If UCase(ws.Name) = UCase(wsConfig.Range("A" & rw)) Then
                    i = i + 1
                End If
                If UCase(ws.Name) = UCase(wsConfig.Range("D" & rw)) Then
                    i = i + 1
                End If
            End If
        Next ws
        For col = 2 To 3
            If wsConfig.Cells(rw, col) <> "" And Len(wsConfig.Cells(rw, col)) <= 2 Then
                If WorksheetFunction.IsText(wsConfig.Cells(rw, col)) Then
                    i = i + 1
                End If
            End If
        Next col
        If wsConfig.Cells(rw, col) <> "" And Len(wsConfig.Cells(rw, col)) <= 2 Then
            If WorksheetFunction.IsText(wsConfig.Cells(rw, 4)) Then
                i = i + 1
            End If
        End If
        'If wsConfig.Range("G" & rw) = 0 Or wsConfig.Range("G" & rw) = 1 Then
            'i = i + 1
        'End If
        If i <> 4 Then
            WarningText = "Warning" & Chr(10) & "Data entered in Config Sheet row " & CStr(rw) & " is not consistent, please check that:"
            WarningText = WarningText & Chr(10) & "1-Sheets exist or there is a misspelled mistake or you haven't entered data."
            WarningText = WarningText & Chr(10) & "2-Required columns entered in Range are alphabetical and not numeric."
            WarningText = WarningText & Chr(10) & "3-Required flag value is not 0 or 1"
            WarningText = WarningText & Chr(10) & Chr(10) & "Program stop"
            MsgBox WarningText, vbCritical
            End
        End If
    Next rw
End Sub

Open in new window

0
 

Author Comment

by:LD16
ID: 41754101
Thank you very much for this proposal.

I tested but I am having the following error message.
2016-08-12-18_30_52-Microsoft-Visual.png2016-08-12-18_31_10-Microsoft-Visual.png

Thank you very much for your help.
0
 

Author Comment

by:LD16
ID: 41759223
@Rgonzo1971: sorry to disturb you. Could you please help me with this debug?

Thank you in advance for your help.
0
Networking for the Cloud Era

Join Microsoft and Riverbed for a discussion and demonstration of enhancements to SteelConnect:
-One-click orchestration and cloud connectivity in Azure environments
-Tight integration of SD-WAN and WAN optimization capabilities
-Scalability and resiliency equal to a data center

 
LVL 50

Accepted Solution

by:
Rgonzo1971 earned 250 total points
ID: 41771238
and now
Sub CopyRangeDynamically()

    Dim wsConfig As Worksheet, wsDestination As Worksheet, wsSourceSheet As Worksheet
    Dim sSheetName As String, sSourceColumn As String, sSourceColumn2 As String, sDestinationColumn, sSheetName2 As String
    Dim rgDestination As Range, rgSource As Range
    Dim rw As Integer, MaxRowSourceSheet As Long

    CheckConfigSheet
    
    Set wsConfig = Worksheets("4.Parameter-Copy-Range")
    Application.ScreenUpdating = False
    For rw = 2 To wsConfig.Range("A1").CurrentRegion.Rows.Count
        sSheetName = wsConfig.Range("A" & rw) '==Original Sheet Name
        Set wsSourceSheet = Worksheets(sSheetName)
        sSheetName2 = wsConfig.Range("D" & rw) '==Destination Sheet Name
        Set wsDestination = Worksheets(sSheetName2)
        MaxRowSourceSheet = wsSourceSheet.Cells.SpecialCells(xlCellTypeLastCell).Row '==Max Row Original Sheet
        sSourceColumn = wsConfig.Range("B" & rw)
        sSourceColumn2 = wsConfig.Range("C" & rw)
        sDestinationColumn = wsConfig.Range("E" & rw)
        sDestinationHeader = wsConfig.Range("F" & rw)
        'MatchCount = 0
        'wsSourceSheet.Select
        Set rgSource = wsSourceSheet.Range(sSourceColumn & "2:" & sSourceColumn2 & MaxRowSourceSheet)
        Set rgDestination = wsDestination.Range(sDestinationColumn & "2")
        rgDestination.Resize(Rows.Count - 1).ClearContents
        rgSource.Copy
        rgDestination.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False ' to clear the clipboard
        wsDestination.Range(sDestinationColumn & "1").Value = sDestinationHeader
    Next
    MsgBox "Process has been done", vbOKOnly 'just as an FYI to the user and pass back control
       
    wsConfig.Select
End Sub


Sub CheckConfigSheet()
    Dim wsConfig As Worksheet, ws As Worksheet, rw As Integer, col As Integer, i As Integer, WarningText As String
    Set wsConfig = Worksheets("4.Parameter-Copy-Range")
    For rw = 2 To wsConfig.Range("A1").CurrentRegion.Rows.Count
        i = 0
        For Each ws In Worksheets
            If wsConfig.Range("A" & rw) <> "" Then
                If UCase(ws.Name) = UCase(wsConfig.Range("A" & rw)) Then
                    i = i + 1
                End If
                If UCase(ws.Name) = UCase(wsConfig.Range("D" & rw)) Then
                    i = i + 1
                End If
            End If
        Next ws
        For col = 2 To 3
            If wsConfig.Cells(rw, col) <> "" And Len(wsConfig.Cells(rw, col)) <= 2 Then
                If WorksheetFunction.IsText(wsConfig.Cells(rw, col)) Then
                    i = i + 1
                End If
            End If
        Next col
        If wsConfig.Cells(rw, col) <> "" And Len(wsConfig.Cells(rw, col)) <= 2 Then
            If WorksheetFunction.IsText(wsConfig.Cells(rw, 4)) Then
                i = i + 1
            End If
        End If
        'If wsConfig.Range("G" & rw) = 0 Or wsConfig.Range("G" & rw) = 1 Then
            'i = i + 1
        'End If
        If i <> 4 Then
            WarningText = "Warning" & Chr(10) & "Data entered in Config Sheet row " & CStr(rw) & " is not consistent, please check that:"
            WarningText = WarningText & Chr(10) & "1-Sheets exist or there is a misspelled mistake or you haven't entered data."
            WarningText = WarningText & Chr(10) & "2-Required columns entered in Range are alphabetical and not numeric."
            WarningText = WarningText & Chr(10) & "3-Required flag value is not 0 or 1"
            WarningText = WarningText & Chr(10) & Chr(10) & "Program stop"
            MsgBox WarningText, vbCritical
            End
        End If
    Next rw
End Sub

Open in new window

0
 
LVL 30

Assisted Solution

by:Subodh Tiwari (Neeraj)
Subodh Tiwari (Neeraj) earned 250 total points
ID: 41771243
You are getting that error because there is nothing to paste.
Rearrange the lines 26, 27 and 28 like below.....
rgDestination.Resize(Rows.Count - 2).ClearContents
rgSource.Copy
rgDestination.PasteSpecial Paste:=xlPasteValues

Open in new window

0
 

Author Comment

by:LD16
ID: 41771361
It works, thank you again for your help!
0
 
LVL 30

Expert Comment

by:Subodh Tiwari (Neeraj)
ID: 41771367
You're welcome. Glad to help.
0

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

0. Preface This Article is a replacement of http:/A_1788-Getting-your-EE-Ranking-statistics-in-Excel.html (http://http:/A_1788-Getting-your-EE-Ranking-statistics-in-Excel.html). Changes in the way Experts Exchange delivers point statistics, impleme…
This is an Add-On procedure to be used in conjunction with the code provided in Reducing EE Email Clutter using Outlook (http://www.experts-exchange.com/Software/Office_Productivity/Groupware/Outlook/A_3146-Outlook-Processing-EE-emails-on-Receive.…
Microsoft Active Directory, the widely used IT infrastructure, is known for its high risk of credential theft. The best way to test your Active Directory’s vulnerabilities to pass-the-ticket, pass-the-hash, privilege escalation, and malware attacks …
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

828 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question