Hi I working some VBA to copy cells to another worksheet in the same workbook. However I am running into an error. Here is the challenege:
Worksheet with data to be searched.
I am looping through cells in Column A and looking for the word Properties: If the words is found I want to copy and paste special(transpose) the values in the adjacent cells up to three rows down to another worksheet in the same workbook.
So for example if the word "Properties is found in cell A9 I need to copy the values in B10:B12 and paste special transpose to the next empty row on Metadata Worksheet.
I got it working to copy the cell Offset(1,1), however I am having difficult expanding the copy range. Please see code below. The commented out code works fine, but the line just below it is what i am trying but it wont work.
Private Sub Search_n_Copy()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
Dim rngCopy As Range, aCell As Range, srchRng As Range
Dim strSearch As String
Dim QueryResults As Worksheet
Set QueryResults = ThisWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
QueryResults.Name = "MetaData"
strSearch = "Properties"
Dim LastRow As Long
With QueryResults
QueryResults.Range("A1").Value = "SI_ID"
QueryResults.Range("B1").Value = "SI_NAME"
QueryResults.Range("C1").Value = "SI_WEBI_DOC_PROPERTIES"
End With
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
Set srchRng = .Range("A1:A" & LastRow)
For Each aCell In srchRng
If aCell.Value = "Properties" Then
''aCell.Offset(1, 1).Copy
.Range("aCell.Offset(1, 1):aCell.Offset(3,1)").Copy
QueryResults.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End If
Next aCell
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Related
I have 5 columns of data. The data is grouped by employee name and number (cols A-B) and their respective pay types (col C). I need to
Copy employee name to blank cell below in col A
Copy employee number to blank cell below in col B
Add the word "Advance" in the blank cell in col C
Current code selects all blank cells in cols A-E and fills with the values from above:
Sub FillBlanksValueAbove1()
Dim sName As String
sName = ActiveSheet.Name
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim rng As Range
'Set variable ws Active Sheet name
Set ws = Sheets(sName)
With ws
'Get the last row and last column
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Set the range
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Select
'Select Blanks
rng.SpecialCells(xlCellTypeBlanks).Select
'Fill Blanks with value above
Selection.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rng.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub
This is what the spreadsheet looks like now:
This is what I need it to look like:
This is the end result I currently get:
Thank you so so much!
Test the next code, please. No need of any selection, a little simplified:
Sub FillBlanksValueAbove1()
Dim rng As Range, rngVis As Range
Dim ws As Worksheet, lastRow As Long
'Set variable ws Active Sheet name
Set ws = ActiveSheet
With ws
'Get the last row
lastRow = .Range("A" & .Rows.count).End(xlUp).Row
'Set the range
Set rng = .Range(.cells(1, 1), .cells(lastRow, 2)) 'Col B:C
Set rngVis = rng.SpecialCells(xlCellTypeBlanks)
'Fill ADVANCE in column C:C
rngVis.Offset(, 1).Value = "ADVANCE"
'Fill Blanks with value above
rngVis.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rngVis.Value = rngVis.Value
End With
End Sub
I have some code in which I am trying to sort the data set in a csv file based on the content of a cell in another (the main) workbook. Then based on this sort, copy a range of visible cells between the first and sixth columns, but with a dynamic last row thus the range will be dynamic. This dynamic range is then pasted into the main sheet, which will then allow me to do further work on this dataset.
Can't seem to get the sort to work or the dynamic range working. I've tried all sorts of variation on the code below and am looking for some inspiration.
Sub Get_OA_Data()
'Find OA data from source SQL file and copy into serial number generator
Dim ws As Worksheet
Dim wkb2 As Workbook
Dim ws2 As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
'This section sets the workbooks and worksheets to be used for this macro
Set ws = ThisWorkbook.Worksheets("Data Entry")
Set wkb2 = Workbooks.Open("\\srvabdotfpr08\PC_APPS\forum\Gateshead Serialisation\sys_serialisation1.csv")
Set ws2 = wkb2.Worksheets("sys_serialisation1")
Set rng2 = ws.Range("F6")
' This line deletes any content of the cannot assign serial number added previously
ws.Range("I6:I7").ClearContents
'This hides all rows which do not match the desired OA number (found in rng2)
For Each Cell In ws2.Range("A1").End(xlDown)
If Left(Cell.Value, 6) <> rng2.Value Then
Cell.EntireRow.Hidden = True
End If
Next Cell
Set StartCell = ws2.Range("A1")
LastRow = StartCell.SpecialCells(xlCellTypeVisible).Row
LastColumn = StartCell.SpecialCells(xlCellTypeVisible).Column
'This section selects and copies the visible range from csv file into serialisation generator
Set rng = ws2.Range(StartCell.ws2.Cells(LastRow, LastColumn))
rng.Copy
ws.Activate
ws.Range("D12").Select
Selection.PasteSpecial 'Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Any help would be greatly appreciated, I've bought a couple of books, but none of the stuff in my books is helping with this issue.
P.S I have used very similar code with specific set ranges and it works fine, but this one has me stumped. There may also be an issue with the dataset- which is why I have the LEFT formula in the code (but this seems to work OK).
Try...
Option Explicit
Sub Get_OA_Data()
Dim wkb2 As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim rng As Range, xCell As Range
Dim LR As Long, LC As Long, LR2 As Long
Set ws = ThisWorkbook.Worksheets("Data Entry")
Set wkb2 = Workbooks.Open("\\srvabdotfpr08\PC_APPS\forum\Gateshead Serialisation\sys_serialisation1.csv")
Set ws2 = wkb2.Worksheets("sys_serialisation1")
ws.Range("I6:I7").ClearContents
LR2 = ws2.Range("A" & ws.Rows.Count).End(xlUp).Row
For Each xCell In ws2.Range("A1:A" & LR2)
xCell.EntireRow.Hidden = Left(xCell.Value, 6) <> ws.Range("F6")
Next xCell
LR = ws2.Range("A" & ws.Rows.Count).End(xlUp).Row
LC = ws2.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set rng = ws2.Range(ws2.Cells(1, 1), ws2.Cells(LR, LC))
rng.SpecialCells(xlCellTypeVisible).Copy
ws2.Range("D12").PasteSpecial xlPasteValues
End Sub
I wrote a macro (mostly by recording it) that copies data from a section on one sheet then calculates the end of my table on another sheet and pastes (paste special, being that the data I am pasting is a formula and I need to paste the values) the data to the end of my table, which on its own increases the size of my table.
That works.
My problem is that I am not sure how much of my original range of data (that I am copying) will actually have values in it (there is a formula that is either giving it a value or ""), so I take a large range, just in case
So.... after I pasted it I would like to go through my table and remove any rows that were added that only had empty strings ("") and no values, and then resize the table so it is only as large as the rows that have data.
These rows can be in the middle or at the end of my pasted data.
I need help on the VBA code to do that.
I may also need to clear the formatting that the table automatically added to those additional rows
here is the code I have until now
Range("O7:R30").Select
Selection.Copy
Sheets("deposits").Select
Dim lastRow As Long
lastRow = ActiveSheet.ListObjects("deposits").Range.Rows.Count
Range("A" & lastRow).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Probably best to only place data into the table if its valid, rather than clean up after the paste.
Something like this
Sub Demo()
Dim rDest As Range
Dim lo As ListObject
Dim wsSrc As Worksheet
Dim rSrc As Variant
Dim i As Long
Dim rng As Range
'there are better ways to get a reference to the source data, but thats not the Q here
Set wsSrc = ActiveSheet
Set rSrc = wsSrc.Range("O7:R30")
' destination sheet
With Sheets("deposits")
'get reference to table
Set lo = .ListObjects("deposits")
'Get reference to first row after the table
Set rDest = lo.DataBodyRange.Rows(lo.DataBodyRange.Rows.Count + 1)
i = 0
'loop thru source data rows
For Each rng In rSrc.Rows
'if a row has data
If Application.WorksheetFunction.CountA(rng) > 0 Then
'copy values into table
rDest.Offset(i).Value = rng.Value
i = i + 1
End If
Next
End With
End Sub
This code worked, not elegant, but it worked
Sub copyToDeposits()
Dim theSheet As String
theSheet = ActiveSheet.Name
Application.ScreenUpdating = False
Range("O7:R30").Select
Selection.Copy
Sheets("deposits").Select
Dim lastRow As Long
lastRow = ActiveSheet.ListObjects("deposits").Range.Rows.Count
Range("A" & lastRow).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim lo As ListObject
Dim lRow As ListRow
Dim rng As Range
Dim delRows As Collection
Set lo = ActiveSheet.ListObjects("deposits") 'change to your table name
On Error Resume Next
For Each lRow In lo.ListRows
Set rng = Nothing
Set rng = lRow.Range.Cells(1, 2)
If Not rng Is Nothing Then
If rng = "" Then
If delRows Is Nothing Then
Set delRows = New Collection
delRows.Add lRow
Else
delRows.Add lRow, Before:=1
End If
End If
End If
Next
On Error GoTo 0
If Not delRows Is Nothing Then
For Each lRow In delRows
lRow.Delete
Next
End If
Sheets(theSheet).Select
Application.ScreenUpdating = True
End Sub
I have a template (named template in the code) and a list of store numbers ( named list in the code). I want to create a new worksheet identical to the template, but replace one cell (E5) with the next number in the list. I have this code but it doesn't seem to work. Any ideas? :
Sub CreateNewSheet()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("List").Range("A2") 'Must change tab name
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets("Template").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets("List").Select
MyCell.Select
Selection.Copy
Sheets(Sheets.Count).Select
Range("E5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets(Sheets.Count).Name = MyCell.Value & "-" ' renames the new worksheet
Range("E5").Select 'Puts driver name in cell
Next MyCell
End Sub
You are overwriting the range for one thing here:
Set MyRange = Sheets("List").Range("A2") 'Must change tab name
Set MyRange = Range(MyRange, MyRange.End(xlDown))
When I think you want to actually create the range to loop over. Note MyRange.End(xlDown) will take you down to the last non-blank cell in the range rather than the last used row.
So, I have changed your syntax to find the last row, stored in a variable, and use that to define the loop range.
lastRow = ws.Range("A2").End(xlDown).Row
Set MyRange = ws.Range("A2:A" & lastRow)
Then I have put the List worksheet in a variable so you don't need to go backwards and forward selecting sheets.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("List")
This means that whenever you add a sheet, which will become the activesheet, you can simply refer access the MyCell value as it is qualified by the sheet name it came from.
This,
Sheets(Sheets.Count).Name = MyCell.Value & "-"
Looks a bit dodgy in terms of naming. Sort of looks unfinished. However, that should be enough to get you going.
Option Explicit
Sub CreateNewSheet()
Dim MyCell As Range
Dim MyRange As Range
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("List")
lastRow = ws.Range("A2").End(xlDown).Row
Set MyRange = ws.Range("A2:A" & lastRow)
Dim counter
For Each MyCell In MyRange
Sheets("Template").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
ActiveSheet.Range("E5") = MyCell
Sheets(Sheets.Count).Name = MyCell.Value & "-" ' renames the new worksheet
Next MyCell
End Sub
i've got a question.
I've got the names of sheets in my workbook in a sheet named "Summary". I've got some stats in a sheet called "Stats". I wanna loop over the names in summary sheet, select each sheet, then copy the values from B2:M2 from "stats" page, transpose copy it to column D2 in the sheet selected from "Summary" sheet. Then I want to move to next sheet from the list of sheets from "Summary" page, copy B3:M3 & copy as transpose the D2 column in the selected sheet & so forth.
I've managed to get this bit of code for it. It's not compelte. I'm unable to figure out how to increment from B2:M2 to B3:M3 to B4:M4 & so on.
Please can someone help me. I've never written VB code before.
Sub transpose()
Dim MyCell As Range, MyRange As Range
Dim row_counter As Long, col_counter As Long
Set MyRange = Sheets("Summary").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
row_counter = 2
col_counter = 2
For Each MyCell In MyRange
Sheets("Stats").Select
Range("B2:M2").Select
Selection.Copy
Sheets(MyCell.Value).Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, transpose:=True
row_counter = row_counter + 1
col_counter = col_counter + 1
Next MyCell
End Sub
See below code (which is your code with the addition of offset).
Offset will let you increment from B2:M2 to B3:M3 asb so on.
I replaced your row and col variable with just x since you only move by row.
Sub transpose()
Dim MyCell As Range, MyRange As Range
Dim x as long
Set MyRange = Sheets("Summary").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
x = 0
For Each MyCell In MyRange
Sheets("Stats").Select
Range("B2:M2").Offset(x, 0).Select
Selection.Copy
Sheets(MyCell.Value).Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, transpose:=True
x = x + 1
Next MyCell
End Sub
Also you can try this:
Dim MyCell, MyRange as Range
Dim wb as Workbook
Dim ws, wsTemp, wsStat as Worksheet
Dim x as Long
Set wb = Thisworkbook
Set ws = wb.Sheets("Summary")
Set wsStat = wb.Sheets("Stats")
With ws
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set MyRange = .Range("A1:A" & lrow)
End With
x = 0
For Each MyCell in MyRange
Set wsTemp = wb.Sheets(MyCell.Value)
wsStat.Range("B2:M2").Offset(x, 0).Copy
wsTemp.Range("D2").PasteSpecial xlPasteAll, , , True
x = x + 1
Set wsTemp = Nothing
Next MyCell
End Sub
Already Tested.
Hope it does what you want to achieve.