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
Related
I have the same code in the same workbook and in a separate sheet and it was working perfectly alright. I copied the same code for the same workbook but different sheet and there goes an error.
Sub ExecuteLkup()
Dim LastRow As Long
Dim LastCol As Long
Dim iRow As Long
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:="V:\Mar22\Top Segments & Top All_Mar22.xlsx")
Set ws = Sheet4
Range("K2").Value = WorksheetFunction.Vlookup(Range("F").Value, wb.Sheets("TopAll").Range("E:I"), 5, 0)
With ws
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Cells(1, LastCol + 1).Value = "Variance"
End With
Range("L2").Select
ActiveCell.FormulaR1C1 = "=[#[BRN_nett_grand_total]]-[#Column1]"
End Sub
I have a table with certain rows with "striked-out" font. The objective is to cut these rows and paste them into another sheet.
So far, I have the following code, and is not working (EDIT: a new sheet gets created but nothing is cut nor pasted):
Sub test()
Dim i As Long, lrow As Long
lrow = Cells(Rows.Count, "A").End(xlUp).Row
Sheets.Add After:=ActiveSheet
For i = 2 To lrow
If Cells(i, 1).Font.Strikethrough = True Then
Cells(i, 1).EntireRow.Cut
Sheets(ActiveSheet.Index + 1).Paste
End If
Next i
End Sub
How would I fix this?
More like this:
Sub test()
Dim i As Long, lrow As Long, wsSrc As Worksheet, wsDest As Worksheet
Dim destRow As Long
Set wsSrc = ActiveSheet 'or something more specific
lrow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
'get a reference to the sheet when adding it
Set wsDest = wsSrc.Parent.Sheets.Add(After:=ActiveSheet)
destRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1
For i = 2 To lrow
If wsSrc.Cells(i, 1).Font.Strikethrough = True Then
wsSrc.Rows(i).Cut wsDest.Cells(destRow, 1)
destRow = destRow + 1 'next paste row
End If
Next i
End Sub
I've wanted to copy and paste specific data on existing worksheet from workbook loaded.
Code is running till get to below row..
(Please find full code on below)
rng.Copy worksheet("WMS").Cells(j, 39)
I guess it has problem with this
worksheet("WMS") (WMS worksheet is existing worksheet)in with loop but has no clue to solve this problem.
Would you give me advise what should I try?
thanks.
Private Sub btnMerge_Click()
Dim WB As Workbook
Dim WS As Worksheet: Dim toWS As Worksheet
Dim rng As Range
Dim i As Long: i = 0: Dim j As Long
Dim endCol As Long: Dim endRow As Long
Dim strWS As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Me.lstWB.ListCount = 0 Then
MsgBox "No file have selected"
Exit Sub
End If
Set toWS = ActiveSheet
j = toWS.Cells(toWS.Rows.Count, 1).End(xlUp).Row
For i = 0 To Me.lstWB.ListCount - 1
Set WB = Application.Workbooks.Open(Me.lstWB.List(i))
For Each WS In WB.Worksheets
With WS
endCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
endRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rng = .Range(.Cells(2, 1), .Cells(2, endRow))
rng.Copy worksheet("WMS").Cells(j, 39)
j = j + rng.Rows.Count
End With
Next
WB.Close
Next
MsgBox "Done"
Unload Me
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Change
Set rng = .Range(.Cells(2, 1), .Cells(2, endRow))
to
Set rng = .Range(.Cells(2, 1), .Cells(endRow, endCol))
Using variant array is more effective.
.rows.count is same with rows.count. Because the number of rows of all sheets is the same.
Private Sub btnMerge_Click()
Dim WB As Workbook
Dim WS As Worksheet: Dim toWS As Worksheet
Dim rng As Range
Dim i As Long: i = 0: Dim j As Long
Dim endCol As Long: Dim endRow As Long
Dim strWS As String
Dim Target As Range, vDB As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Me.lstWB.ListCount = 0 Then
MsgBox "No file have selected"
Exit Sub
End If
Set toWS = ActiveSheet
'j = toWS.Cells(toWS.Rows.Count, 1).End(xlUp).Row
For i = 0 To Me.lstWB.ListCount - 1
Set WB = Application.Workbooks.Open(Me.lstWB.List(i))
For Each WS In WB.Worksheets
With WS
endCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
endRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'Set rng = .Range(.Cells(2, 1), .Cells(2, endRow))
vDB = .Range(.Cells(2, 1), .Cells(endRow, endCol))
'rng.Copy Worksheet("WMS").Cells(j, 39)
Set Target = toWS.Cells(Rows.Count, 39).End(xlUp)(2)
'j = j + rng.Rows.Count
Target.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
End With
Next
WB.Close
Next
MsgBox "Done"
Unload Me
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Please help me to understand what I am doing wrong ?
Why when I do this it works: Range("E2:E" & Lrow).copy
But when I do this rng.copy it doesn't ?
Option Explicit
Sub CopyL()
Dim Lrow As Long
Dim Lcol As Long
Dim rng As Range
Dim sht As Worksheet
Set sht = Worksheets("Sheet1")
Set rng = sht.Range("E2:E" & Lrow)
Lrow = Cells(Rows.Count, 4).End(xlUp).Row
rng.Copy
End Sub
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