I have been trying to figure out why I am not able to paste values only in this VBA module. Can anyone spot my issue? I have tried many different combinations, and still getting compile errors
Sub Merge_Sheets()
'Set Master sheet for consolidation
Set mtr = Worksheets("Master")
Set wb = ThisWorkbook
'loop through all sheets
For Each ws In wb.Worksheets
'except the master sheet from looping
If ws.Name <> "Master" Then
ws.Activate
Range("A5:P20").Copy _
mtr.Range("A" & mtr.Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial xlPasteValues
End If
Next ws
Worksheets("Master").Activate
End Sub
Does anyone have any ideas for the issue on this? Thanks in advance!
Append Range Values From All Worksheets
Option Explicit
Sub AppendRangeValues()
Const SRC_RANGE As String = "A5:P20"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Sheets("Master")
Dim dfCell As Range
Set dfCell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
Dim drg As Range, rCount As Long
With dws.Range(SRC_RANGE)
rCount = .Rows.Count
Set drg = dfCell.Resize(rCount, .Columns.Count)
End With
Dim sws As Worksheet
For Each sws In wb.Worksheets
If Not sws Is dws Then
drg.Value = sws.Range(SRC_RANGE).Value
Set drg = drg.Offset(rCount)
End If
Next sws
MsgBox "Range values appended.", vbInformation
End Sub
Related
I would like to copy a Cell from all worksheet but "Data" Worksheet on column C of "Data Worksheet". The following code is not working properly, always blank value. The value I would like to copy is placed on E16 Cell.
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Data" Then
x = x + 1
Sheets("Data").Range("B1").Offset(x) = Worksheets(ws.Name).Cells(4, 16).Value
End If
Next ws
Try it that Way, without coping every value by it's own:
Sub m()
vartemp2 = Range("A1:A2")
vartemp2 = WorksheetFunction.Transpose(vartemp2)
Dim varTemp As Variant
For Each ws In Worksheets
If ws.Name <> "Data" Then
If i = 0 Then
ReDim varTemp(1 To 1, 1 To 1)
i = 1
Else
varTemp = WorksheetFunction.Transpose(varTemp)
ReDim Preserve varTemp(1 To UBound(varTemp) + 1)
varTemp = WorksheetFunction.Transpose(varTemp)
End If
varTemp(UBound(varTemp), 1) = ws.Cells(16, 5).Value
End If
Next ws
With Worksheets("Data")
.Range(.Cells(1, 2), .Cells(UBound(varTemp), 2)).Value = varTemp
End With
End Sub
BTW: On your code, 4 is column D not E. Columns start with 1 on counting and the defintion is Cells(RowNumber, ColumnNumber) :)
Copy Single Cell's Value From All Other Worksheets
Compact
Sub CopySingleCellValuesCompact()
Dim wb As Workbook: Set wb = ActiveWorkbook ' possibly use 'ThisWorkbook'
Dim dws As Worksheet: Set dws = wb.Worksheets("Data")
Dim dCell As Range: Set dCell = dws.Range("B1")
Dim sws As Worksheet
Dim sCell As Range
For Each sws In wb.Worksheets
If Not sws Is dws Then
Set sCell = ws.Range("E16")
Set dCell = dCell.Offset(1)
dCell.Value = sCell.Value
End If
Next sws
End Sub
Argumented
Now, to get rid of the magic numbers, you could create a method...
Sub CopySingleCellValues( _
ByVal wb As Workbook, _
ByVal DestinationWorksheetName As String, _
ByVal DestinationLastCellAddress As String, _
ByVal SourceCellAddress As String)
Dim dws As Worksheet: Set dws = wb.Worksheets(DestinationWorksheetName)
Dim dCell As Range: Set dCell = dws.Range(DestinationLastCellAddress)
Dim sws As Worksheet
Dim sCell As Range
For Each sws In wb.Worksheets
If Not sws Is dws Then
Set sCell = ws.Range(SourceCellAddress)
Set dCell = dCell.Offset(1)
dCell.Value = sCell.Value
End If
Next sws
End Sub
Usage
... and in your code, use it in the following way:
Sub MyCode()
Dim wb As Workbook: Set wb = ActiveWorkbook ' possibly use 'ThisWorkbook'
CopySingleCellValues wb, "Data", "B1", "E16"
End Sub
... and keep your code clean as a whistle.
It reads something like: in the given workbook, from all worksheets except worksheet Data, copy the value from cell E16 to worksheet Data, one below the other, starting with the first cell below B1.
I don't use VBA much at all. I found some code online that has me moving in the right direction, however, I'm struggling how to copy just the values in column "A" rather than copying all the rows. The bold/italic area is where I believe the problem lies.
`For i = 2 To a
If Sheets(Range("O1").Value).Cells(i, 9).Value = "False" Then
***Sheets(Range("O1").Value).Rows(i).Copy***
Worksheets("Product_Lookup").Activate
B = Worksheets("Product_Lookup").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Product_Lookup").Cells(B + 1, 1).Select
ActiveSheet.Paste
Worksheets("Product_Lookup").Activate`
Using Variables
By using variables, your code will become more readable (understandable).
Activating and selecting often leads to mistakes and it severely slows down the operation. Avoiding this is
illustrated in this post.
The following illustrates the Workbook-Worksheet-Range hierarchy.
' The usual approach is e.g.:
'Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
'Dim iws As Worksheet: Set iws = wb.Worksheets("Sheet1")
' Note that 'iws' could actually be 'dws', we don't know!
Dim iws As Worksheet: Set iws = ActiveSheet ' unknown worksheet?
Dim wb As Workbook: Set wb = iws.Parent
Dim sws As Worksheet
On Error Resume Next ' check if the worksheet exists
Set sws = wb.Worksheets(CStr(iws.Range("O1").Value)) ' it may be empty!
On Error GoTo 0
If sws Is Nothing Then Exit Sub ' the worksheet doesn't exist
Dim dws As Worksheet: Set dws = wb.Worksheets("Product_Lookup")
Dim dCell As Range
Set dCell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
For i = 2 To a
If CStr(sws.Cells(i, "I").Value) = "False" Then
sws.Cells(i, "A").Copy dCell
' If you only need values then the following is more efficient:
'dCell.Value = sws.Cells(i, "A").Value
Set dCell = dCell.Offset(1)
End If
Next i
I've been wanting to copy the value but also the format and the cell color of the last non empty cell in column B, and past it in cell B1 in all the sheets.
Here is the code I used, but I always get an error.
Sub copypaste()
Dim wb As Workbook
Dim ws As Worksheet
Dim Lastcell As String
Application.ScreenUpdating = False
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
Lastcell = ws.Cells(Rows.Count, "B").End(xlUp).Cell
Lastcell.Copy
ws.Range("B1").PasteSpecial Paste:=xlPasteFormats
ws.Range("B1").PasteSpecial Paste:=xlPasteValue
Next ws
Set wb = Nothing
End Sub
could you please help ?
Thanks in advance
Cell Copy in Multiple Worksheets
Option Explicit
Sub CopyPaste()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
Dim sCell As Range ' Source Cell Range
Dim dCell As Range ' Destination Cell Range
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
' Cells...
Set dCell = ws.Cells(1, "B")
Set sCell = ws.Cells(ws.Rows.Count, "B").End(xlUp)
' ... or Range...
'Set dCell = ws.Range("B1")
'Set sCell = ws.Range("B" & ws.Rows.Count).End(xlUp)
' Fastest (if it covers what you need)
dCell.Value = sCell.Value
dCell.NumberFormat = sCell.NumberFormat
dCell.Interior.Color = sCell.Interior.Color
' Fast
' sCell.Copy dCell
' dCell.Value = sCell.Value
' Slow (the selection changes)
' sCell.Copy
' dCell.PasteSpecial xlPasteValues
' dCell.PasteSpecial xlPasteFormats
Next ws
' Only for the Slow version:
'Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
You look to be declaring Lastcell as a string but treating it as a range. Something like this would work.
Sub copypaste()
Dim wb As Workbook
Dim ws As Worksheet
Dim Lastcell As Range
Application.ScreenUpdating = False
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
Set Lastcell = ws.Cells(Rows.Count, "B").End(xlUp)
Lastcell.Copy
ws.Range("B1").PasteSpecial Paste:=xlPasteValues
ws.Range("B1").PasteSpecial Paste:=xlPasteFormats
Next ws
Set wb = Nothing
End Sub
The final code is this
Sub Unique_Values_Worksheet_Variables()
'1 Code + Sub splitByChars
Const Chars As Long = 4
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("export")
Dim dws As Worksheet:
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
sws.Range("C:C").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=dws.Range("A:A"), _
Unique:=True
dws.Columns("A:J").EntireColumn.AutoFit
Dim rng As Range:
Set rng = dws.Range("A1:B1", dws.Cells(dws.Rows.Count, 1).End(xlUp))
rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.HorizontalAlignment = xlCenter
Unfortunately this was just focused on one part which has to be copied, the values for these columns were in another column so i try to switch the code
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("export")
Dim dws As Worksheet:
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
sws.Range("C:C").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=dws.Range("A:A"), _
Unique:=True
to this. I used the macro reader for it.
Sub Test()
'
' Test Makro
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.ActiveSheet
Dim dws As Worksheet:
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
Application.ScreenUpdating = False
sws.Columns("C:C").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Columns("D:H").EntireColumn.Hidden = True
Columns("C:J").Select
Selection.Copy Destination:=dws.Range("A1")
End Sub
what works:
the code recognizes the part with the new worksheet dws.
it filters in sws the column C:C, what means
it also recognizes sws
what does not work:
by copy paste the range no values are hand over.
I have to use the advanced filter on C:C by avoiding duplicates, then i have data which i do not want to handover in column "D:I". The only thing what i want to hand over is column C & J. So i tried it with hiding the columns in between but it does not work.
Has anybody an idea?
i also tried it with .Delete what actually would be not that nice.
Is it a problem that i just assigned A1 for pasting it?
Selection.Copy Destination:=dws.Range("A1")
Copy Columns (Unique)
About Your Solution
Your solution is pretty cool. You probably meant to hide D:I though, which is a minor issue.
After hiding and filtering you might consider unhiding the columns and removing the filter to bring the source worksheet to the initial state.
I prefer using a worksheet with a name instead of ActiveSheet, but it's no big deal if you know what you're doing.
I don't like the references to the whole columns i.e. letting Excel (VBA) decide which range should be processed.
About the following
I first wrote the second code which is kind of more efficient but comes with the cost of not being able to control the order of the columns (due to Union) to be copied, hence the first code is recommended.
You can easily replace the source worksheet (Worksheets(sName)) with ActiveSheet if necessary.
It is assumed that the source data (table (one row of headers)) starts in cell A1. Otherwise, you may need to create the source range reference in a different way.
Adjust (play with) the values in the constants section.
Option Explicit
Sub copyColumnsUnique()
' Source
Const sName As String = "Sheet1"
Const sUniqueColumn As String = "C"
Const sCopyColumnsList As String = "C,J" ' exact order of the columns
' Destination (new worksheet)
Const dFirst As String = "A1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sCopyColumns() As String: sCopyColumns = Split(sCopyColumnsList, ",")
Dim dCell As Range: Set dCell = wb.Worksheets _
.Add(After:=wb.Sheets(wb.Sheets.Count)).Range(dFirst)
Application.ScreenUpdating = False
Dim srg As Range
With wb.Worksheets(sName).Range("A1").CurrentRegion
.Columns(sUniqueColumn).AdvancedFilter xlFilterInPlace, , , True
Dim n As Long
For n = 0 To UBound(sCopyColumns)
.Columns(sCopyColumns(n)).Copy dCell
Set dCell = dCell.Offset(, 1)
Next n
.Parent.ShowAllData
End With
Application.ScreenUpdating = True
End Sub
Sub copyColumnsUniqueAsc()
' Source
Const sName As String = "Sheet1"
Const sUniqueColumn As String = "C"
Const sCopyColumnsList As String = "C,J" ' forced ascending order of columns
' Destination (new worksheet)
Const dFirst As String = "A1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sCopyColumns() As String: sCopyColumns = Split(sCopyColumnsList, ",")
Application.ScreenUpdating = False
Dim srg As Range
With wb.Worksheets(sName).Range("A1").CurrentRegion
.Columns(sUniqueColumn).AdvancedFilter xlFilterInPlace, , , True
' Using 'Union' will force the resulting columns be in ascending order.
' If 'sCopyColumnsList' is "C,J,D", the order will be "C,D,J".
Dim n As Long
For n = 0 To UBound(sCopyColumns)
If srg Is Nothing Then
Set srg = .Columns(sCopyColumns(n))
Else
Set srg = Union(srg, .Columns(sCopyColumns(n)))
End If
Next n
End With
srg.Copy wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Range(dFirst)
srg.Parent.ShowAllData
Application.ScreenUpdating = True
End Sub
Thanks to #Tragmor
for everyone who has same kind of problems, this could solve it
Sub Test()
'
' Test Makro
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.ActiveSheet
Dim dws As Worksheet:
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
Application.ScreenUpdating = False
With sws
.Columns("C:C").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
.Columns("D:H").EntireColumn.Hidden = True
.Columns("C:J").Copy Destination:=dws.Range("A1")
End With
End Sub
I have 2 different excel files, stored in C:\Test:
Book1.xlsx, with Sheet1 (data in the Sheet1 is changing, not constant data-range, but always starts from A1 cell)
Book2.xlsm, with Sheet2 (empty)
Every time after opening Book2, I need data from Sheet1 of Book1 to be automatically copied into Sheet2 of Book2.
Update:
I tried the following vba code (researched online from Excel Forum)
Private Sub Workbook_Open()
Application.EnableEvents = False
Dim swb As Workbook, Lr As Long, LC As Long, sws As Worksheet
Dim dCell As Range, srg As Range, dwb As Workbook, dws As Worksheet
Set swb = Workbooks.Open("C:\Test\AAA\Book1.xlsx")
Set sws = swb.Worksheets("Sheet1")
Lr = sws.Cells(Rows.Count, 1).End(xlUp).Row
LC = sws.Cells(1, Columns.Count).End(xlToLeft).Column
Set srg = sws.Range(Cells(1, 1), Cells(Lr, LC))
Set dwb = ThisWorkbook
Set dws = dwb.Worksheets("Sheet2")
Set dCell = dws.Range("A1")
srg.Copy dCell
swb.Close SaveChanges:=False
dwb.Save
Application.EnableEvents = True
End Sub
But, the problem with this - that if I delete a few records after the 1st one from Sheet1 of Book1, then - these deleted records still appear in the Sheet2 of Book2!
I am not great in vba, it's just a part of my whole project
Sorry for these questions
Update 2:
When I have the following in Sheet1, Book1:
Then, after opening Sheet2, Book2, I see (which is correct, what I expected):
But, if I'll delete records in Sheet1, Book1 (starting from the 2nd):
Then, after opening Sheet2, Book2 I will still see those deleted from Book2 records (while I expect them to be gone):
When the destination sheet has more data than the source sheet, you will need to clear it before you copy over the data. You could do it with the Range-method ClearContents:
Set dws = dwb.Worksheets("Sheet2")
dws.Usedrange.ClearContents
Set dCell = dws.Range("A1")
srg.Copy dCell
As it seems that you are copying the data of the whole sheet, an alternative could be to remove the sheet in ThisWorkbook and copy the sheet itself:
' Delete Sheet2 (if present)
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Sheet2").Delete
Application.DisplayAlerts = True
On Error GoTo 0
' Copy Sheet from sourceWorkbook
sws.Copy after:=ThisWorkbook.Sheets(1)
ActiveSheet.Name = "Sheet2" ' Copied sheet gets the active sheet automatically.
Clear Range Below Copied Data
Private Sub Workbook_Open()
Application.EnableEvents = False
Dim swb As Workbook, sws As Worksheet, srg As Range, LR As Long, LC As Long
Dim dwb As Workbook, dws As Worksheet, dCell As Range
Set swb = Workbooks.Open("C:\Test\AAA\Book1.xlsx")
Set sws = swb.Worksheets("Sheet1")
LR = sws.Cells(sws.Rows.Count, 1).End(xlUp).Row
LC = sws.Cells(1, sws.Columns.Count).End(xlToLeft).Column
Set srg = sws.Range(sws.Cells(1, 1), sws.Cells(LR, LC))
Set dwb = ThisWorkbook
Set dws = dwb.Worksheets("Sheet2")
Set dCell = dws.Range("A1")
srg.Copy dCell
With dCell.Resize(, srg.Columns.Count)
.Resize(.Worksheet.Rows.Count - .Row - srg.Rows.Count + 1) _
.Offset(srg.Rows.Count).Clear
End With
swb.Close SaveChanges:=False
dwb.Save
Application.EnableEvents = True
End Sub