VBA - copying to other sheets - excel

I have this code, by a responder who helped me to define my needs yesterday - but there somethings i want to change, but my vba skills are very low and dont know how and where to modify the code. I want it do 2 Things.
Right know it transferes data, i want it to copy it, over with the values that are calculated in the cells. I have some cells, where i have some formulas and it dosent follows with it. I just want the calculated value over. I dont know if i can use xlPasteValues somewhere to get what i want?
The second thing that i want is, when copying over, i want to be on top and the previous copies move Down, so the latest copy always are in the top.
Thank you before handed :)
Option Explicit
Sub Copypastemeddata()
Dim wb As Workbook
Dim ws As Worksheet
Dim sourceCell As Range
Dim targetSheet As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Opgørsel")
Set sourceCell = ws.Range("D3") 'Cell with sheet names for copying to
With ws
Set targetSheet = wb.Worksheets(sourceCell.Text)
Dim nextRow As Long
nextRow = GetLastRow(targetSheet, 1)
nextRow = IIf(nextRow = 1, 1, nextRow + 1)
.Range("A1").CurrentRegion.Copy targetSheet.Range("A" & nextRow)
targetSheet.Columns.AutoFit
End With
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function

Please give this a try...
The StartRow variable defines the destination row on targetSheet, you may change it as per your requirement.
Sub Copypastemeddata()
Dim wb As Workbook
Dim ws As Worksheet
Dim sourceCell As Range
Dim targetSheet As Worksheet
Dim StartRow As Integer
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Opgørsel")
Set sourceCell = ws.Range("D3") 'Cell with sheet names for copying to
StartRow = 1 'Destination row on targetSheet
With ws
Set targetSheet = wb.Worksheets(sourceCell.Text)
.Range("A1").CurrentRegion.Copy
targetSheet.Range("A" & StartRow).Insert shift:=xlDown
targetSheet.Range("A" & StartRow).PasteSpecial xlPasteValues
targetSheet.Columns.AutoFit
End With
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub

substitute
Dim nextRow As Long
nextRow = GetLastRow(targetSheet, 1)
nextRow = IIf(nextRow = 1, 1, nextRow + 1)
.Range("A1").CurrentRegion.Copy targetSheet.Range("A" & nextRow)
with
With .Range("A1").CurrentRegion
targetSheet.Rows(1).Resize(.Rows.Count).Insert shift:=xlUp
targetSheet.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With

Related

VBA merging different sheets doesn't work

I would like to consolidate several sheets by copying data starting from A40 in each sheet
and pasting in a new worksheet
The code doesn't result in error but nothing is copied
Could you help please
Thanks
Sub merge_cognos()
Dim wb As Workbook
Dim ws As Worksheet
Dim startRow As Long
Dim startcol As Integer
Dim lastCol As Long
Dim lastRow As Long
Set wb = ActiveWorkbook
Set ws_new = ActiveWorkbook.Sheets.Add
For Each ws In wb.Worksheets
If ws.Name <> ws_new.Name Then
startRow = 40
startcol = 1
lastRow = Cells(Rows.Count, startcol).End(xlUp).Row
lastCol = Cells(startRow, Columns.Count).End(xlToRight).Column
'get data from each worksheet and copy it into Master sheet
Range(Cells(startcol, startRow), Cells(lastRow, lastCol)).Copy
ws_new.Paste
End If
Next ws
ws_new.Select
With Selection
.Range("F1", Range("F1").End(xlDown)).Sort Key1:=Range("F1"), Order1:=xlDescending, Header:=xlNo
.Columns("F:F").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End With
End Sub
I revised your code in order to:
avoid use of Select/Selection
reference the proper worksheet at every stage
as follows:
Sub merge_cognos()
Dim wb As Workbook
Dim ws As Worksheet
Dim startRow As Long
Dim startcol As Integer
Dim lastCol As Long
Dim lastRow As Long
Set wb = ActiveWorkbook
Dim ws_new As Worksheet
Set ws_new = wb.Sheets.Add
For Each ws In wb.Worksheets
With ws
If .Name <> ws_new.Name Then
startRow = 40
startcol = 1
lastRow = .Cells(.Rows.Count, startcol).End(xlUp).Row
lastCol = .Cells(startRow, .Columns.Count).End(xlToLeft).Column
'get data from each worksheet and copy it into Master sheet
.Range(.Cells(startRow, startcol), .Cells(lastRow, lastCol)).Copy
With ws_new
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial
End With
End If
End With
Next
With ws_new
.Range("F1", .Range("F1").End(xlDown)).Sort Key1:=.Range("F1"), Order1:=xlDescending, Header:=xlNo
.Columns("F:F").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

Change a column's contents to uppercase in all worksheets

I'm trying to loop through each worksheet in my workbook and change the text in column G to upper case, with the header column remaining unchanged.
Sub capitalize_columns()
Dim wb as ThisWorkbook
Dim ws as Worksheet
set wb = ThisWorkbook
For Each ws in wb.worksheets
With ws
Dim last_row as Long
last row = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim capital_range As Range
Set capital_range = ws.Range("G2:G" & last_row)
capital_range.Value = capital_range.Parent.Evaluate("Index(UPPER(" & name_range.Address & "),)")
End With
Next ws
End Sub
The script runs but I it doesn't produce my desired result of capitalizing the everything in column G with the exception of the header.
I think you are overcomplicating the upper case part. All you need is UCase() in a loop like shown here:
Sub capitalize_columns()
Dim ws As Worksheet
Dim row As Long
Dim last_row As Long
For Each ws In ThisWorkbook.Worksheets
With ws
last_row = .Cells(.Rows.Count, 1).End(xlUp).Row ' use column A to find last row
For row = 2 To last_row ' start at row 2
.Range("G" & row) = UCase(.Range("G" & row))
Next
End With
Next ws
End Sub
Your code is good! Index(UPPER()) is a faster way as it doesn't loop as mentioned in Convert an entire range to uppercase without looping through all the cells. Your code just needs few fixes.
Fixes:
Declare the objects on the top and not in the loop.
Find the last row of column G and not A. You may not get the true range if the column data is uneven.
Use Option Explicit. It will catch typos like last_row Vs last row and also name_range
Code:
Option Explicit
Sub capitalize_columns()
Dim wb As ThisWorkbook
Dim ws As Worksheet
Dim last_row As Long
Dim capital_range As Range
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
With ws
'~~> Find last row in col G
last_row = .Cells(.Rows.Count, 7).End(xlUp).Row
Set capital_range = .Range("G2:G" & last_row)
capital_range.Value = .Evaluate("Index(UPPER(" & capital_range.Address & "),)")
End With
Next ws
End Sub

vba code to insert copied cells in another worksheet

i need to insert copied rows into another worksheet
i write this code and it doesn`t insert it, it gives me error.
Sub IsEmptyExample1()
Dim wss As Sheets
Dim ws As Worksheet
Set wss = ThisWorkbook.Worksheets
Set ws = wss("Sheet1")
wsLR = ws.Cells(Rows.Count, 1).End(xlUp).Row
For x = 1 To wsLR
Cells(x, 1).Select
If IsEmpty(ActiveCell.Value) = False Then
ThisWorkbook.Worksheets("sheet1").Rows(x).Select
Selection.Copy
Sheets("DE Portal LL").Select
Selection.Insert Shift:=xlDown
Else
End If
Next x
End Sub
I think you should read this to learn how to avoid using select. You had a few undeclared variables in your code. Your code was also copying a row and then trying to insert a new row onto a worksheet with that data. It would be better to just copy and paste to a new worksheet. Let me know if this helps:
Sub IsEmptyExample2()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim Source As Range
Set Source = Worksheets("Sheet1").Range(("A1"), Range("A1").End(xlDown).End(xlToRight))
Dim DestRange As Range
Set DestRange = Worksheets("DE Portal LL").Range("A1")
Dim wsLR As Long
wsLR = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim x As Long
For x = 1 To wsLR
If Cells(x, 1).Value <> "" Then
Source(x, 1).Rows.EntireRow.Copy
DestRange(x, 1).PasteSpecial xlPasteAll
End If
Next x
End Sub

How to copy row to another sheet if the cell value of C matches the sheetname

So I pull data then I have to copy and paste the rows to their respective sheets basing on the value of Column D. I have a code that does the thing but it takes too slow when there are thousands of rows.
Sub COPY_DATA()
Dim bottomD As Long
bottomD = Range("D" & Rows.Count).End(xlUp).Row
Dim c As Range
Dim ws As Worksheet
For Each c In Sheets("Data").Range("D2:D" & bottomD)
For Each ws In Sheets
ws.Activate
If ws.Name = c And ws.Name <> "Userform" Then
c.EntireRow.copy Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next ws
Next c
Worksheets("Data").Activate
End Sub
I want to make the process of copy and pasting faster
This should be faster:
Sub COPY_DATA()
Dim dict As Object
Dim bottomD As Long
Dim c As Range
Dim ws As Worksheet,wb as workbook, wsData as Worksheet
Set wb = ActiveWorkbook
Set wsData = wb.worksheets("Data")
'collect the sheet names
Set dict = CreateObject("scripting.dictionary")
For Each ws In wb.Worksheets
If ws.Name <> "Userform" Then dict.Add ws.Name, True
Next ws
Application.ScreenUpdating = False
bottomD = wsData.Range("D" & Rows.Count).End(xlUp).Row
For Each c In wsData.Range("D2:D" & bottomD)
If dict.exists(c.Value) Then
c.EntireRow.Copy wb.Worksheets(c.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next c
Application.ScreenUpdating = True
wsData.Activate
End Sub
Stop .Activating! Totally unnecessary and updating the UI is taking time. Make sure all calls to ranges are qualified.
Option Explicit '<--- Always at the top of modules!
Sub COPY_DATA()
Dim bottomD As Long
bottomD = Range("D" & Rows.Count).End(xlUp).Row
Dim c As Range
Dim ws As Worksheet
For Each c In Sheets("Data").Range("D2:D" & bottomD)
For Each ws In Sheets
With ws
If .Name = c.Value And .Name <> "Userform" Then
c.EntireRow.copy Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
End With
Next ws
Next c
End Sub
Note also that I explicitly stated c.Value instead of using the implicit/default property (which just happens to be Value).

Clipboard in VBA disappears after few steps

I have a code that should restore range formatting after applying few step.
Sub MyCode()
Sheets("My sheet").ListObjects("My Table").DataBodyRange.Copy
...
refreshing connection and calling function that applies stored formulas to table columns
...
Sheets("My sheet").[A10].PasteSpecial Paste:=xlPasteFormats
End sub
I got error PasteSpecial method on range failed
If I paste immediately, it works.
Is it possible to save range formatting as variable?
Here is an example on how to use variables to store the copy method and use it later. You can set the range to a variable CopyRange and use CopyRange.Copy to store it and later you can use it as the range was stored in the CopyRange and not lost along the way due to other processes running down the line.
Option Explicit
Sub CopyDataToTemplate()
Dim ws As Worksheet
Dim srcWB As Workbook
Dim destWB As Workbook
Dim srcWS As Worksheet
Dim destWS As Worksheet
Dim CopyRange As Variant
Dim i As Long, j As Long
Dim srcLRow As Long, destLRow As Long
Set destWB = Excel.Workbooks("DOLine_example.xlsx")
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.ActiveSheet
Set destWS = destWB.Sheets("DOLine")
srcLRow = srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Row
destLRow = destWS.Cells(destWS.Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
'loop through column 1 to 19
For i = 1 To 19
For j = 1 To 13
'loop through columns
If destWS.Cells(3, i).value = srcWS.Cells(1, j).value Then
' Copy column B to Column D as written in your code above
Set CopyRange = srcWS.Range(Cells(2, j), Cells(srcLRow, j))
CopyRange.Copy
' paste columns from one wb to Columns to another wb
destWS.Cells(destLRow, i).PasteSpecial Paste:=xlPasteAll, Transpose:=False
Application.CutCopyMode = False
End If
Next j
Next i
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub

Resources