I want to move data from one workbook to another for mapping. I don't need the header and want to skip blanks.
I can get it to skip blanks but then it copies the columns beside it.
I can also get it to copy and paste only the column but it doesn't skip the blanks. So I just need a way for it to do column A only, no header, and keep it blank on the new sheet.
I've tried Skip blanks in the Paste special and it doesn't work.
Sub NewCopyandPaste()
Dim wsSource As Worksheet
Dim weTarget As Worksheet
Dim y As Range
Set wsSource = Workbooks("Book1.csv").Worksheets("Book1")
Set weTarget = Workbooks("Book2.csv").Worksheets("Book2")
With wsSource
Set y = .Range(.Range("A2"), .Range("A2").End(xlDown))
y.SpecialCells(xlCellTypeConstants).Copy
End With
weTarget.Range("C2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub
Your issue is that
Set y = .Range(.Range("A2"), .Range("A2").End(xlDown))
sets y to the range from A2 down to the cell above first blank cell Note 1
hange that to use End(XlUp) from the bottom of the sheet
Set y = .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp)) ' .Range("A2").End(xlDown))
Note 1. stritcly speaking, what is copied will depend on if cell A3 is blank.
I think the problem might be with your range creation. Try:
Dim wsSource As Worksheet
Dim weTarget As Worksheet
Dim y As Range
Set wsSource = Workbooks("Book1.csv").Worksheets("Book1")
Set weTarget = Workbooks("Book2.csv").Worksheets("Book2")
With wsSource
Set y = Range("A2").End(xlDown)
y.SpecialCells(xlCellTypeConstants).Copy
End With
weTarget.Range("C2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Related
I am working on a vba small code which extract date from Column A into Column C. the current code puts the formulas to extract date from Cell C2 to C2500, However if the data in Column A ends at line A600 it still goes down till C2500. Is it possible if we amend the code to stop pasting the formula exactly at the last line of Column A. so that i do not need to manually delete those cells "#Value". e.g. see print shot.
Sub Formula_property()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = Sheets("Sheet3")
wb.Activate
ws.Select
Range("C2:C2500").Formula = "=extractDate(A2:A2)"
End Sub
Assuming that all columns have the same number of rows (except column B which is empty) - we can use CurrentRegion to get the size of the target "for free"
Sub formula()
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet3")
Dim rg As Range
Set rg = ws.Range("A1").CurrentRegion
Set rg = rg.Columns(1)
With rg
.Offset(1, 1).Resize(.Rows.Count - 1).formula = "=extractDate(A2:A2)"
End With
End Sub
BTW: activate/select is not necessary - I recommend reading How to avoid using select.
I want to create a command button which copies a range of cells and pastes them into the next empty range.
I have found a code online which I tweaked to perform the function, but it does not work when I add conditional formatting.
The conditional formating being, blank cells = yellow.
The VBA im currently using is:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Sheet1")
copySheet.Range("B11:J11").Copy
pasteSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
If I enter a value into the blank cell the above VBA works fine, however if I leave the cell blank it does not paste into the next cell.
The aim was for the user to paste in as many rows as needed, and the yellow shading to indicate which cells to add a value in.
I hope this makes sense. I'm not particularly used to these functions in excel.
Try this code:
Private Sub CommandButton1_Click()
'Macro to copy in a new row.
'Turning off screen updating.
Application.ScreenUpdating = False
'Declarations.
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim targetRange As Range
'Setting variables.
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Sheet1")
'Setting targetRange as the last cell in column B with value.
Set targetRange = pasteSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
'Setting targetRange as the first cell in column B with no conditional formatting under the last cell in column B with no value.
Do Until targetRange.FormatConditions.Count = 0
Set targetRange = targetRange.Offset(1, 0)
Loop
'Copying range B11:J11.
copySheet.Range("B11:J11").Copy
'Pasting the copied range in targetRange.
targetRange.PasteSpecial xlPasteAll
'Turning off the cut-copy mode.
Application.CutCopyMode = False
'Turning on the screen updating.
Application.ScreenUpdating = True
End Sub
I've taken your code and added the variable targetRange. Said variable is then set as the last cell with value in column B (similar to what you have already done) and then i use a Do Loop cycle to set targetRange as the first cell with no conditional formatting under the last cell with value in column B. I've also added the proper comments to the whole code.
Extra code as requested in comments.
You can obtain a sum of the values of a range while counting any "outgoing" value as a 7 with this formula:
=SUM(B11:B15,COUNTIF(B11:B15,"ongoing")*7)
You can use the same formula in a macro like this:
Sub Macro1()
'A example of macro to return a range sum with any "ongoing" switched with 7.
'Declaration.
Dim rng As Range
'Setting the seed range.
Set rng = Range("B11")
'Expanding rng to the last cell with value of its column.
Set rng = Range(rng, Cells(Rows.Count, rng.Column).End(xlUp))
'Reporting in the immediate window the result.
Debug.Print Excel.WorksheetFunction.Sum(rng, Excel.WorksheetFunction.CountIf(rng, "ongoing") * 7)
'Reporting in the immediate window the result, this time using a With End With statement to make it more readable.
With Excel.WorksheetFunction
Debug.Print .Sum(rng, .CountIf(rng, "ongoing") * 7)
End With
End Sub
Need some help here. Row A is used for headers and has a "Autofilter" applied for Field 16, in this case when filtering it to find "Q1". I will be repeating this step for other quarters.
I am trying to only copy a specific row and range at a time. So for example: first Column A...copy what has only been filtered then paste where i desire...then I would a write new line to get only Column D and paste that where ever i desire.
I am using UsedRange at the moment but unsure how I would transition out of it. Would Range(A:A) work and Range("B:B") then if it was consecutive can I do Range(F:H) for columns F,G and G=H. However keep getting Error 1004
Hope I have made sense
Dim a As Workbook
Dim b As Worksheet
Dim c As Worksheet
Dim d As Worksheet
Set a = ThisWorkbook
Set b = Worksheets("Opportunity(BE)")
Set c = Worksheets("Pipeline(BE)")
Set d = Worksheets("Renewal(BE)")
a.Worksheets("Probable").Range("A1:T1").AutoFilter Field:=17,
Criteria1:="Open"
a.Worksheets("Probable").Range("A1:T1").AutoFilter Field:=16, Criteria1:="Q1"
a.Worksheets("Probable").Range("B:B").Offset(1).SpecialCells(xlCellTypeVisible).Copy
b.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Untested, but one way is to use Intersect to capture the specific column you want.
Sub x()
Dim a As Workbook
Dim b As Worksheet
Dim c As Worksheet
Dim d As Worksheet
Dim r As Range
Set a = ThisWorkbook
Set b = Worksheets("Opportunity(BE)")
Set c = Worksheets("Pipeline(BE)")
Set d = Worksheets("Renewal(BE)")
With a.Worksheets("Probable")
.Range("A1:T1").AutoFilter Field:=16, Criteria1:="Open"
Set r = Intersect(.Range("B:B"), .AutoFilter.Range) 'column B of filtered data
r.Offset(1).Resize(r.Rows.Count - 1).Copy 'remove header
b.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End With
End Sub
When i am pasting Amount data which i copied from filtered range through VBA code, I do not get the correct result.
How can i copy and paste the correct filtered range in VBA?
I have tried in so many ways like visible cells and resize.
Dim Rangedata as Range, U as Range
'Table Range
Set Rangedata = D.Range("A1:C" & Range("A1").End(xlDown).Row)
Rangedata.AutoFilter Field:=2, Criteria1:=Log.Cells(8, 3)
'Amount which i want to copy without Header
Set U = D.Range("C1:C" & Range("C1").End(xlDown).Row)
U.Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
U.copy
There are almost 22 Amounts but i am only getting 10 Amounts.
You'll need to add in variables to reference the two workbooks, but hopefully this example will work.
Sub CopyPasteFilteredRange()
Dim D As Worksheet
Dim Log As Worksheet
Dim PasteHere As Worksheet
Dim Rangedata As range, U As range
Dim Lastrow As Long 'Get Last Row
Set D = Worksheets("D")
Set Log = Worksheets("Log")
Set PasteHere = Worksheets("PasteHere") 'Added Sheet PasteHere as Example
'Remove Filtered Criteria Before Filtering
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
'Table Range
Set Rangedata = D.range("A1:C" & range("A1").End(xlDown).Row)
Rangedata.AutoFilter Field:=2, Criteria1:=Log.Cells(8, 3)
'Amount which i want to copy without Header
'If you have filtered above on Column B, but if there are blank cells in Col C .End(XlDown will stop at first blank value, so add lastRow to capture all used rows
Lastrow = D.UsedRange.Rows(D.UsedRange.Rows.Count).Row
Set U = D.range("C1:C" & Lastrow)
'Set U to Visable Cells otherwise what you are .copying is still = D.range("C1:C" & range("C1").End(xlDown).Row)
Set U = U.Offset(1, 0).SpecialCells(xlCellTypeVisible)
U.Copy 'Don't have to Select U
PasteHere.range("A1").PasteSpecial
End Sub
I am trying to loop through four tabs, copying data from three input tabs and pasting it into the remaining, master, tab. The code should loop through all the column headings on the master tab, find whether the same heading exists in any of input tabs and, if it does, copy and paste the data into the relevant column of the master tab.
At the moment, I have got all the data from the first input tab into the master tab but I am having difficulties getting data from the remaining input tabs to paste below the data from the first input tab.
This is the code as it stands at the moment:
Sub master_sheet_data()
Application.ScreenUpdating = False
'Variables
Dim ws1_xlRange As Range
Dim ws1_xlCell As Range
Dim ws1 As Worksheet
Dim ws2_xlRange As Range
Dim ws2_xlCell As Range
Dim ws2 As Worksheet
Dim ws3_xlRange As Range
Dim ws3_xlCell As Range
Dim ws3 As Worksheet
Dim ws4_xlRange As Range
Dim ws4_xlCell As Range
Dim ws4 As Worksheet
Dim valueToFind As String
Dim lastrow As String
Dim lastrow2 As String
Dim copy_range As String
'Assign variables to specific worksheets/ranges
'These will need to be updated if changes are made to the file.
Set ws1 = ActiveWorkbook.Worksheets("Refined event data - all")
Set ws1_xlRange = ws1.Range("A1:BJ1")
Set ws2 = Worksheets("Refined event data")
Set ws2_xlRange = ws2.Range("A1:BJ1")
Set ws3 = Worksheets("Refined MASH data")
Set ws3_xlRange = ws3.Range("A1:BJ1")
Set ws4 = Worksheets("Raw RHI data - direct referrals")
Set ws4_xlRange = ws4.Range("A1:BJ1")
'Loop through all the column headers in the all data tab
For Each ws1_xlCell In ws1_xlRange
valueToFind = ws1_xlCell.Value
'Loop for - Refined event data tab
'check whether column headers match. If so, paste column from event tab to relevant column in all data tab
For Each ws2_xlCell In ws2_xlRange
If ws2_xlCell.Value = valueToFind Then
ws2_xlCell.EntireColumn.Copy
ws1_xlCell.PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws2_xlCell
'Loop for - Refined ID data tab
'check whether column headers match. If so, paste column from MASH tab to the end of relevant column in all data tab
For Each ws3_xlCell In ws3_xlRange
If ws3_xlCell.Value = valueToFind Then
Range(ws3_xlCell.Address(), ws3_xlCell.End(xlDown).Address()).Copy
lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws3_xlCell
'Loop for - direct date data tab
'check whether column headers match. If so, paste column from direct J4U tab to the end of relevant column in all data tab
For Each ws4_xlCell In ws4_xlRange
If ws4_xlCell.Value = valueToFind Then
Range(ws4_xlCell.Address(), ws4_xlCell.End(xlDown).Address()).Copy
lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws4_xlCell
Next ws1_xlCell
End Sub
At the moment, this section of code:
For Each ws3_xlCell In ws3_xlRange
If ws3_xlCell.Value = valueToFind Then
Range(ws3_xlCell.Address(), ws3_xlCell.End(xlDown).Address()).Copy
lastrow = ws1.Cells(Rows.Count, ws1_xlCell.Column).End(xlUp).Row + 1
Cells(ws1_xlCell.Column & lastrow).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ws3_xlCell
Seems to be selecting the correct range on the correct sheet and copying it. The lastrow variable seems to be picking up the correct row on the master tab but the data is not pasted. I've tried naming the ranges and using Cells() rather than Range() but neither appeared to work.
Any ideas as to how to get the data to paste would be much appreciated.
Cheers,
Ant
What I did was make a function that would find the column header and return the data range from from that column.
Sub master_sheet_data()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim cell As Range, source As Range, target As Range
With ThisWorkbook.Worksheets("Raw RHI data - direct referrals")
For Each ws In Worksheets(Array("Refined event data - all", "Refined event data", "Refined MASH data"))
For Each cell In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft))
Set source = getColumnDataBodyRange(ws, cell.Value)
If Not source Is Nothing Then
Set target = cell.Offset(.Rows.Count - 1).End(xlUp).Offset(1)
source.Copy
target.PasteSpecial xlPasteValuesAndNumberFormats
End If
Next
Next
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Function getColumnDataBodyRange(ws As Worksheet, ColumnHeader As Variant) As Range
Dim cell As Range
With ws
Set cell = .Rows(1).Find(What:=ColumnHeader, After:=.Range("A1"))
If Not cell Is Nothing Then
Set getColumnDataBodyRange = .Range(cell.Offset(1), cell.Offset(.Rows.Count - 1).End(xlUp))
End If
End With
End Function