• Status: Solved
  • Priority: Medium
  • Security: Private
  • Views: 60
  • Last Modified:

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

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
LD16
Asked:
LD16
  • 3
  • 2
  • 2
2 Solutions
 
Rgonzo1971Commented:
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
 
LD16Author Commented:
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
 
LD16Author Commented:
@Rgonzo1971: sorry to disturb you. Could you please help me with this debug?

Thank you in advance for your help.
0
Cloud Class® Course: Microsoft Exchange Server

The MCTS: Microsoft Exchange Server 2010 certification validates your skills in supporting the maintenance and administration of the Exchange servers in an enterprise environment. Learn everything you need to know with this course.

 
Rgonzo1971Commented:
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
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
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
 
LD16Author Commented:
It works, thank you again for your help!
0
 
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome. Glad to help.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Cloud Class® Course: Microsoft Azure 2017

Azure has a changed a lot since it was originally introduce by adding new services and features. Do you know everything you need to about Azure? This course will teach you about the Azure App Service, monitoring and application insights, DevOps, and Team Services.

  • 3
  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now