SolvedPrivate

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

Posted on 2016-08-12
8
52 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
[X]
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
  • 3
  • 2
  • 2
8 Comments
 
LVL 51

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
On Demand Webinar: Networking for the Cloud Era

Did you know SD-WANs can improve network connectivity? Check out this webinar to learn how an SD-WAN simplified, one-click tool can help you migrate and manage data in the cloud.

 
LVL 51

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 31

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 31

Expert Comment

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

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

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

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.…
Describes a method of obtaining an object variable to an already running instance of Microsoft Access so that it can be controlled via automation.
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…
In this brief tutorial Pawel from AdRem Software explains how you can quickly find out which services are running on your network, or what are the IP addresses of servers responsible for each service. Software used is freeware NetCrunch Tools (https…

691 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