In one file I have data (Zeszyt.xlsm - Sheet1) and in the other an empty file (Sheet2) with the same headers and fill in button. However, when I press the button. There is no mistake but nothing complements. Could you help me ?
Private Sub CommandButton2_Click()
Dim wb As Workbook
ThisWorkbook.Worksheets("Sheet1").Rows(12).Copy
Selection.Copy
Set wb = Workbooks.Open("C:\Users\admin\Desktop\TEST\Zeszyt2.xlsm")
wb.Worksheets("Sheet2").Activate
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Cells(lastrow + 1, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close savehanges = True
Set wb = Nothing
ThisWorkbook.Worksheets("Sheet1").Activate
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Select
Application.CutCopyMode = False
End Sub
There is no need to select or copy/paste.
First of all I would propose to put all parameters like workbook names etc. as constants to the header of the module. By that it is much easier to fix renamings etc.
By having a generic copyRangeValues-routine you can re-use this sub for other copy-actions as well:
Option Explicit
'config source
Private Const wsSourceName As String = "Sheet1"
Private Const rowToCopy As Long = 12 'is this really always row 12????
Private Const wbTargetName As String = "C:\Users\admin\Desktop\TEST\Zeszyt2.xlsm"
Private Const wsTargetName As String = "Sheet2"
Private Sub CommandButton2_Click()
'First step: prepare your source range
Dim wbSource As Workbook
Set wbSource = ThisWorkbook
Dim wsSource As Worksheet
Set wsSource = wbSource.Worksheets(wsSourceName)
Dim rgSource As Range
Set rgSource = wsSource.Rows(rowToCopy)
'second step: prepare your top left target cell
Dim wbTarget As Workbook
Set wbTarget = Workbooks.Open(wbTargetName)
Dim wsTarget As Worksheet
Set wsTarget = wbTarget.Worksheets(wsTargetName)
Dim lastRow As Long
lastRow = wsTarget.UsedRange.Rows.Count
Dim rgTargetCell As Range
Set rgTargetCell = wsTarget.Cells(lastRow + 1, 1)
'third step: copy range - use generic routine
copyRangeValues rgSource, rgTargetCell
'fourth step: close target workbook
wbTarget.Close saveChanges:=True
End Sub
'Put this in a general module
Public Sub copyRangeValues(rgSource As Range, rgTargetCell As Range)
'generic routine to copy one range to another
'rgTargetCell = top left corner of target range
Dim rgTarget As Range
'resize rgTarget according to dimensions of rgSource
With rgSource
Set rgTarget = rgTargetCell.Resize(.Rows.Count, .Columns.Count)
End With
'write values from rgSource to rgTarget - no copy/paste necessary!!!
'formats are not copied - only values
rgTarget.Value = rgSource.Value
End Sub
Copy Row To Another File
The code will run slower if you use Activate and Select. but not if you use variables.
Option Explicit
Private Sub CommandButton2_Click()
Const swsName As String = "Sheet1"
Const sRow As Long = 12
Const dFilePath As String _
= "C:\Users\admin\Desktop\TEST\Zeszyt2.xlsm"
Const dwsName As String = "Sheet2"
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets(swsName)
Dim srg As Range: Set srg = sws.Rows(sRow)
Application.ScreenUpdating = False
Dim dwb As Workbook: Set dwb = Workbooks.Open(dFilePath)
Dim dws As Worksheet: Set dws = dwb.Worksheets(dwsName)
Dim dCell As Range
Set dCell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
srg.Copy Destination:=dCell
dwb.Close SaveChanges:=True
Application.ScreenUpdating = True
MsgBox "Done.", vbInformation, "Append Row"
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.
So I have a workbook with multiple sheets. All contain the same columns but just different categorical data. I want to grab all the data from those sheets and display/populate to a master sheet in the workbook.
I have tried different methods, but none of them are dynamic. The amount of data can be changed (+/-, either more rows or less rows) in each sheet. Each method I have found seems to be a static solution.
One example is to use the Consolidate option under the data tab, and add the respective reference/range for each sheet you would like to add (not dynamic).
Another option I found was a VBA macro, which populates the headers over and over, which I do not want to happen either, I want them all under the same header (Since the columns are already the same)
Sub Combine()
'UpdatebyExtendoffice20180205
Dim I As Long
Dim xRg As Range
Worksheets.Add Sheets(1)
ActiveSheet.Name = "Combined"
For I = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
Next
End Sub
Is this achievable?
Sheet 1
Sheet 2
Master Sheet Should Be:
But actually returns the following:
Will this constantly run each time the workbook is closed/opened/updated if it is a macro enabled workbook?
Consolidate All Worksheets
It is assumed that the Combined worksheet already exists with at least the headers which will stay intact.
To make it more efficient, only values are copied (no formats or formulas).
It will utilize the Worksheet Activate event: each time you activate (select) the combined worksheet, the data will automatically be updated.
Sheet Module of the Combined worksheet e.g. Sheet10(Combined)
Option Explicit
Private Sub Worksheet_Activate()
CombineToMaster
End Sub
Standard Module e.g. Module1
Option Explicit
Sub CombineToMaster()
Const dName As String = "Combined"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim drrg As Range
With dws.UsedRange
If .Rows.Count = 1 Then
Set drrg = .Offset(1)
Else
.Resize(.Rows.Count - 1).Offset(1).Clear
Set drrg = .Resize(1).Offset(1)
End If
End With
Dim sws As Worksheet
Dim srg As Range
Dim drg As Range
Dim rCount As Long
For Each sws In wb.Worksheets
If sws.Name <> dName Then
With sws.UsedRange
rCount = .Rows.Count - 1
If rCount > 0 Then
Set srg = .Resize(rCount).Offset(1)
drrg.Resize(rCount).Value = srg.Value
Set drrg = drrg.Offset(rCount)
End If
End With
End If
Next sws
End Sub
VBA Solution
Sub Combine()
Dim wsCombine As Worksheet: Set wsCombine = GetSheetCombine
Dim dataSheets As Collection: Set dataSheets = GetDataSheets
' Copy Header
dataSheets.Item(1).UsedRange.Rows(1).Copy
wsCombine.Range("A1").PasteSpecial xlPasteAll
wsCombine.Range("A1").PasteSpecial xlPasteColumnWidths
Application.CutCopyMode = False
' Copy data
Dim rngDest As Range: Set rngDest = wsCombine.Range("A2")
Dim srcRng As Range
Dim ws As Worksheet
For Each ws In dataSheets
' Drop header row
With ws.UsedRange
Set srcRng = .Offset(1, 0).Resize(.Rows.Count - 1)
End With
srcRng.Copy rngDest
Set rngDest = rngDest.Offset(srcRng.Rows.Count)
Next ws
Application.CutCopyMode = False
MsgBox "Done!", vbInformation
End Sub
Private Function GetSheetCombine() As Worksheet
Dim ws As Worksheet
With Worksheets
On Error Resume Next
Set ws = .Item("Combine")
On Error GoTo 0
If ws Is Nothing Then
Set ws = .Add(Before:=.Item(1))
ws.Name = "Combine"
Else
ws.Cells.Clear ' clear any existing data
End If
End With
Set GetSheetCombine = ws
End Function
Private Function GetDataSheets() As Collection
Dim Result As New Collection
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "Combine" Then Result.Add ws
Next ws
Set GetDataSheets = Result
End Function
As to your question "Will this run every time macro enabled workbook is open?".
No. You will need to put this in a VBA module and run it every time you need, via the Macro dialog (View->Macros), or link a button to it.
I want to select particular columns and then paste this onto a particular sheet, if sheet exists then erase existing data and paste newly copied data. This should work in loop to be refreshed with new data entered in the main sheet.
My code creates the required sheet but pastes data into another new sheet.
Sub Datasort()
'The sheet with all the imported data columns must be active when this macro is run
Dim newSht As Worksheet, sSht As Worksheet, Hdrs As Variant, i As Long, Fnd As Range, Sheet_Name As String
Set sSht = Worksheets("all zip codes")
'Expand the array below to include all relevant column headers
Hdrs = Array("Country", "Zip codes", "GSS")
Application.ScreenUpdating = False
Sheet_Name = "Dataformatted"
Set newSht = Worksheets.Add(after:=sSht)
With sSht.UsedRange.Rows(1)
For i = LBound(Hdrs) To UBound(Hdrs)
Set Fnd = .Find(Hdrs(i), lookat:=xlWhole)
If Not Fnd Is Nothing Then
Intersect(Fnd.EntireColumn, sSht.UsedRange).Copy
newSht.Cells(1, i + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
newSht.Cells(1, i + 1).PasteSpecial Paste:=xlPasteColumnWidths
End If
Next i
Application.CutCopyMode = False
End With
If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
Worksheets.Add(after:=sSht).Name = Sheet_Name
End If
Application.ScreenUpdating = True
End Sub
Function Sheet_Exists(WorkSheet_Name As String) As Boolean
Dim newSht As Worksheet
Sheet_Exists = False
For Each newSht In ThisWorkbook.Worksheets
If newSht.Name = WorkSheet_Name Then
Sheet_Exists = True
End If
Next
End Function
(not tested), but you're adding sheet everytime it runs, so assuming everything else works fine, you should:
replace Set newSht = Worksheets.Add(after:=sSht) with below
if not Sheet_Exists(Sheet_Name) then Worksheets.Add(after:=sSht).Name = Sheet_Name
Set newSht = Worksheets(Sheet_Name)
and remove the following part
If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
Worksheets.Add(after:=sSht).Name = Sheet_Name
End If
Copy Worksheet Columns
Option Explicit
Sub Datasort()
Const sName As String = "all zip codes"
Const dName As String = "Dataformatted"
Const dfcAddress As String = "A1"
Dim Headers As Variant: Headers = VBA.Array("Country", "Zip codes", "GSS")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.UsedRange
Dim shrg As Range: Set shrg = srg.Rows(1)
Application.ScreenUpdating = False
Dim dws As Worksheet
On Error Resume Next
Set dws = wb.Worksheets(dName)
On Error GoTo 0
If dws Is Nothing Then
Set dws = wb.Worksheets.Add(After:=sws)
dws.Name = dName
Else
dws.UsedRange.Clear
End If
Dim dfCell As Range: Set dfCell = dws.Range(dfcAddress)
Dim scrg As Range
Dim hIndex As Variant
Dim c As Long
For c = 0 To UBound(Headers)
hIndex = Application.Match(Headers(c), shrg, 0)
If IsNumeric(hIndex) Then
Set scrg = srg.Columns(hIndex)
dfCell.Resize(scrg.Rows.Count).Value = scrg.Value
dfCell.EntireColumn.ColumnWidth = scrg.EntireColumn.ColumnWidth
Set dfCell = dfCell.Offset(, 1)
End If
Next c
Application.ScreenUpdating = True
MsgBox "Data formatted."
End Sub
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