SolvedPrivate

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

Posted on 2016-08-12
8
47 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
Master Your Team's Linux and Cloud Stack!

The average business loses $13.5M per year to ineffective training (per 1,000 employees). Keep ahead of the competition and combine in-person quality with online cost and flexibility by training with Linux Academy.

 
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 29

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 29

Expert Comment

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

Featured Post

Simplifying Server Workload Migrations

This use case outlines the migration challenges that organizations face and how the Acronis AnyData Engine supports physical-to-physical (P2P), physical-to-virtual (P2V), virtual to physical (V2P), and cross-virtual (V2V) migration scenarios to address these challenges.

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.…
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
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…

770 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