If the sheet name is "Central " (with a space at the end of the word), zone = "Central" returns an error and the sheet cannot be activated.
How do i correct this?
dim wb1, wb2, wb3 as workbook
set wb1 = activeworkbook 'the macro file
dim ws1, ws2 as worksheet
set ws1 = Sheets("Central Zone")
set ws2 = Sheets("Eastern Zone")
For x = 1 To 2
If x = 1 Then
Set ws = ws1
zone = "Central"
End If
If x = 2 Then
Set ws = ws2
zone = "East"
End If
wb2.Sheets(zone).Activate 'wb2 is source file 1. I have wb3, wb4, etc
Selection.EntireColumn.Hidden = False
Range("A1").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.EntireRow.Select
Selection.Copy
wb1.Activate
ws.Activate
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
Next x
It's allways recommended to stay away from Activate, Selection, Select and all other "relatives". Instead use referenced objects, like Sheets, and `Ranges.
The code below is a little "quick and dirty" but it should give you the result you want
Code
Option Explicit
Sub CopyCentralSheets()
Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, Sht As Worksheet, ws As Worksheet
Dim LastRow As Long, LastColumn As Long, PasteRow As Long, x As Long
Set wb1 = ThisWorkbook ' this macro file
'Set wb2 = Workbooks("temp.xlsx") 'for my debug tests only
Set ws1 = wb1.Sheets("Central Zone")
Set ws2 = wb1.Sheets("Eastern Zone")
For x = 1 To 2
If x = 1 Then
For Each Sht In wb2.Worksheets
If Sht.Name Like "Central*" Then
Set ws = Sht
End If
Next Sht
Else
If x = 2 Then
For Each Sht In wb2.Worksheets
If Sht.Name = "East" Then
Set ws = Sht
End If
Next Sht
End If
End If
With ws
LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
LastColumn = .UsedRange.Columns(.UsedRange.Columns.Count).Column
.Range(.Cells(1, 1), .Cells(LastRow, LastColumn)).Copy
End With
If x = 1 Then
With ws1
PasteRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & PasteRow + 1).PasteSpecial xlValues
End With
Else
If x = 2 Then
With ws2
PasteRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & PasteRow + 1).PasteSpecial xlValues
End With
End If
End If
Next x
End Sub
Related
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
So I have two workbooks one is week on week reporting workbook and 2nd one is from where I want to paste the data. So basically I want to copy specific columns from 2nd workbook and paste it into the last row available of the reporting workbook. The reporting workbook has week on week rolling data data should get paste in the last row every time. The code below i have tried but it only copies data to another workbook but not the the last row available of the reporting workbook.
Sub pull_columns()
Dim head_count As Integer
Dim row_count As Integer
Dim col_count As Integer
Dim i As Integer
Dim j As Integer
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Sheet2")
'count headers in this workbook
head_count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))
'open other workbook and count rows and columns
Workbooks.Open Filename:="C:\Users\ritwi\Desktop\Book1.xlsm"
ActiveWorkbook.Sheets(1).Activate
row_count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
col_count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))
For i = 1 To head_count
j = 1
Do While j <= col_count
If ws.Cells(1, i) = ActiveSheet.Cells(1, j).Text Then
ActiveSheet.Range(Cells(1, j), Cells(row_count, j)).Copy
ws.Cells(1, i).PasteSpecial xlPasteValues
Application.CutCopyMode = False
j = col_count
End If
j = j + 1
Loop
Next i
ActiveWorkbook.Close savechanges:=False
ws.Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub
One way of doing it. Be sure to update the wb/ws and range references to suit.
Sub AppendData()
Dim wb1, wb2 As Workbook
Dim ws1, ws2 As Worksheet
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Set wb1 = ThisWorkbook
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set wb2 = Application.Workbooks.Open(ws1.Range("A2").Value)
Application.ScreenUpdating = False
Set wsCopy = wb1.Sheets("Sheet2")
Set wsDest = wb2.Sheets("Sheet1")
'LastRow
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
'Find first blank row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
'Copy & Paste Data
wsCopy.Range("A2:D" & lCopyLastRow).Copy wsDest.Range("A" & lDestLastRow)
Application.CutCopyMode = False
Application.ScreenUpdating = True
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
I have a copy-if routine where I have had trouble finding how to paste values only. Can someone please help?
My routine is as follows:
Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = Workbooks("Bok2.xlsx").Sheets("Ark1")
Dim ws2 As Worksheet: Set ws2 = Workbooks("Bok2.xlsx").Sheets("Ark2")
Dim ws3 As Worksheet: Set ws3 = ThisWorkbook.Sheets("Ark1")
For i = 2 To ws1.Range("A100").End(xlUp).Row
If ws1.Cells(i, 1) = "Videreføres" Then ws2.Range("B1:B100")(i).Copy ws3.Range("A1:A100")(ws3.Cells(ws3.Range("A1:A100").Count, 1).End(xlUp).Row + 1)
If ws1.Cells(i, 1) = "Videreføres" Then ws2.Range("C1:C100")(i).Copy ws3.Range("B1:B100")(ws3.Cells(ws3.Range("B1:B100").Count, 1).End(xlUp).Row + 0)
If ws1.Cells(i, 1) = "Videreføres" Then ws2.Range("E1:E100")(i).Copy ws3.Range("C1:C100")(ws3.Cells(ws3.Range("C1:C100").Count, 1).End(xlUp).Row + 0)
Next i
End Sub
You're just pasting what you've copied where as in fact you need to use the PasteSpecial function. Try looking at this:
Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Workbooks("Bok2.xlsx").Sheets("Ark1")
Set ws2 = Workbooks("Bok2.xlsx").Sheets("Ark2")
Set ws3 = ThisWorkbook.Sheets("Ark1")
For i = 2 To ws1.Range("A100").End(xlUp).Row
If ws1.Cells(i, 1) = "Videreføres" Then
With ws2
.Range("B1:B100")(i).Copy
ws3.Range("A1:A100")(ws3.Cells(ws3.Range("A1:A100").Count, 1).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
.Range("C1:C100")(i).Copy
ws3.Range("B1:B100")(ws3.Cells(ws3.Range("B1:B100").Count, 1).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues
.Range("E1:E100")(i).Copy
ws3.Range("C1:C100")(ws3.Cells(ws3.Range("C1:C100").Count, 1).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues
End With
End If
Next i
End Sub
What I want to achieve is to copy data from WS1 to WS3 based on certain criteria.
I have 2 worksheets:
WS1 = RAW DATA
WS2 = ATLAS DATA
In columns A of both there are unique identifiers. What I want to do is to create WS3=Reconciliation. Then look up values in WS2 against WS1. Where a match is found I want to copy row(s) from WS1 to WS3 that all
I have reverse engineered some code and came up with one below
Sub CopyAndPaste()
Dim x As String, CpyRng As Range
Dim mFIND As Range, mFIRST As Range
With Sheets("RAW DATA")
Range("A:A").Select
On Error Resume Next
End With
With Sheets("ATLAS DATA")
Set mFIND = .Range("A:A").Find(x, LookIn:=xlValues, LookAt:=xlWhole)
If Not mFIND Is Nothing Then
Set CpyRng = mFIND
Set mFIRST = mFIND
Do
Set CpyRng = Union(CpyRng, mFIND)
Set mFIND = .Range("A:A").FindNext(mFIND)
Loop Until mFIND.Address = mFIRST.Address
CpyRng.EntireRow.Copy Sheets("Rec").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
End With
End Sub
Based on your description of your problem; try this
Option Explicit
Sub CopyAndPaste()
Application.ScreenUpdating = False
Dim i As Long, j As Long, lastRow1 As Long, lastRow2 As Long, cnt As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = ActiveWorkbook.Sheets("RAW DATA")
Set ws2 = ActiveWorkbook.Sheets("ATLAS DATA")
Set ws3 = ActiveWorkbook.Sheets("Reconciliation")
lastRow1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
lastRow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
cnt = 1
For i = 1 To lastRow1
For j = 1 To lastRow2
If StrComp(CStr(ws2.Range("A" & j).Value), _
CStr(ws1.Range("A" & i).Value), _
vbTextCompare) = 0 Then
ws1.Activate
ws1.Rows(i).Select
Selection.Copy
ws3.Activate
ws3.Range("A" & cnt).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Application.CutCopyMode = False
cnt = cnt + 1
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub