COPY PASTE AS PER CELL VALUE

venumkd

New Member
Joined
Feb 4, 2020
Messages
45
Office Version
  1. 2010
Sirs

I need an Excel VBA / Macro for the following function. This is for a Data Entry Work.

I am having a worksheet containing 3000 worksheets in which 1500 sheets are having contents done manually. These contents are to be copied to other sheets without changing cell formats.

The sheet names to be copied shall be mentioned in Sheet1 of the same workbook in Column A starting from cell A1 to downwards. The sheet names where to copy also shall be given in the same sheet in Column B starting from Cell B1 to downwards against each corresponding Sheet names in Column A.

Thanking you, yours faithfully

VENU P.K.
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
use a TEST workbook to try this !
- copy typical worksheets into the new workbook
- rename the sheet containing the 2 columns "List"
- place the code in a module like Module1
- run the code

What the code does
- it tests to ensure all sheets in columns A & B in sheet "List" exist (to prevent the code failing)
- assigns VALUES from (used range) in sheet in column A to sheet in column B (same result as copy & paste values, but is faster

Code assumes sheet names begin in A2 (amend to A1 if necessary)
VBA Code:
Option Explicit

Sub CopySheetContent()
    Dim cel As Range, rng As Range, uRng As Range, pRng As Range, msg As String
    Set rng = Sheets("List").Range("A2", Sheets("List").Range("A9999").End(xlUp))
'test sheet existence
    For Each cel In rng.Resize(, 2)
        If Not SheetExists(cel.Text) Then msg = msg & vbCr & cel.Address(0, 0) & vbTab & cel.Text
    Next
    If Not msg = "" Then GoTo Handling
'assign values
    For Each cel In rng.Resize(, 1)
        Set uRng = Sheets(cel.Text).UsedRange
        Set pRng = Sheets(cel.Offset(, 1).Text).Range(uRng.Address)
        pRng.Value = uRng.Value
    Next cel
Exit Sub
Handling:
MsgBox msg, vbExclamation, "oops - list of sheets not found"
End Sub
    
Function SheetExists(ByVal SheetName As String) As Boolean
    Dim Sh As Worksheet
    For Each Sh In ThisWorkbook.Worksheets
        If Application.Proper(Sh.Name) = Application.Proper(SheetName) Then
            SheetExists = True
            Exit Function
        End If
    Next Sh
    SheetExists = False
End Function
 
Upvote 0
Sirs

While running the above macro, it shows

Compile Error

Sub or Function not defined

Subscript out of Range

Etc.

What to do further

Pl, help
 
Upvote 0
The code works - I tested it again without modifying anything
Which LINE is the code failing on for you?
 
Upvote 0
Sir,

I am working with OFFICE 2010 / EXCEL 2010.

Is it because of that it not working? If so can you provide me a VBA compatible to EXCEL 201
 
Upvote 0
Step through the code with {F8}
Which LINE is the code failing on for you?
 
Upvote 0
Sir

Code is working. But format is not being copied such as cell size, colors etc. Only content is copied. I am attaching the scree shot of the original and copied sheets.

I need the copies without changing the formatting.

Thanking you, yours faithfully

VENU P.K.
 

Attachments

  • IMG 1.png
    IMG 1.png
    124.6 KB · Views: 4
  • IMG 2.png
    IMG 2.png
    142.2 KB · Views: 4
Upvote 0
Rich (BB code):
Replace:
pRng.Value = uRng.Value
With:
uRng.Copy pRng
 
Upvote 0
If row heights and column widths also being pasted ....

Replace this line
VBA Code:
    pRng.Value = uRng.Value

with this code
VBA Code:
'declare another variable
    Dim cel As Range
   
    uRng.copy
'paste format and values
    pRng.PasteSpecial (xlPasteAll)
'paste ColumnWidths
    pRng.PasteSpecial (xlPasteColumnWidths)
'paste Row Heights
    For Each cel In uRng.Resize(, 1)
        pRng.Parent.Range(cel.Address).EntireRow.RowHeight = Cel.RowHeight
    Next Cel
 
Upvote 0

Forum statistics

Threads
1,213,482
Messages
6,113,908
Members
448,532
Latest member
9Kimo3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top