SolvedPrivate

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

Posted on 2016-08-12
8
45 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 49

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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
LVL 49

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 28

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 28

Expert Comment

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

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

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.…
Some code to ensure data integrity when using macros within Excel. Also included code that helps secure your data within an Excel workbook.
This video demonstrates how to create an example email signature rule for a department in a company using CodeTwo Exchange Rules. The signature will be inserted beneath users' latest emails in conversations and will be displayed in users' Sent Items…
This is a video describing the growing solar energy use in Utah. This is a topic that greatly interests me and so I decided to produce a video about it.

932 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

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now