I am trying to create a spreadsheet whereby I have a value in a cell in a worksheet called "Equipment" cell C5, for example a Value of 4.
Starting Cell Image
I need to use this value to copy a section of the same row (D5:M5) and paste it that many times into a worksheet called "Programming" also if this changes I would like it to delete or add where required, ignoring where there is a blank or 0 value in the "equipment" sheet
Desired Result
I have around 30 different items and all will have different sections to copy but they will be of the same size. Also Could this look down a list of values all in the same column and do the same for all the values
I'm very new to VBA and have managed to hide and show tabs based on values but i'm struggling to get my head around this as it's a little too complicated at this point.
Thank You in advance
Lee
This is what I have so far, I have edited the code to what I believe is correct but it still isn't working
Sub copySheetCells()
'loop by each cell in column "C"
For i = 2 To Sheets("Equipment").Cells(Rows.Count, "C").End(xlUp).Row
'repeat copy x times (based on cell in column "C" value)
For j = 0 To (Sheets("Equipment").Cells(i, "C").Value - 1)
'define source range
Source = "D" & (i) & ":M" & (i)
'find last row on second sheet
lastRowS2 = Sheets("Hardware_Programming").Cells(Rows.Count, "A").End(xlUp).Row
'copy data
Sheets("Equipment").Range(Source).copy Destination:=Sheets("Hardware_Programming").Range("A" & lastRowS2 + 1)
Next j
Next i
'copy headers
Sheets("Equipment").Range("D1:M1").copy Destination:=Sheets ("Hardware_Programming").Range("A1:J1")
End Sub
I only get blank spaces, is anyone able to advise any further?
Here you go, use this macro. Based on names Programming and Equipment as originally requested.
Sub copySheetCells()
'loop by each cell in column "C"
For i = 2 To Sheets("Programming").Cells(Rows.Count, "C").End(xlUp).Row
'repeat copy x times (based on cell in column "C" value)
For j = 0 To (Sheets("Programming").Cells(i, "C").Value - 1)
'define source range
Source = "D" & (i) & ":M" & (i)
'find last row on second sheet
lastRowS2 = Sheets("Equipment").Cells(Rows.Count, "A").End(xlUp).Row
'copy data
Sheets("Programming").Range(Source).copy Destination:=Sheets("Equipment").Range("A" & lastRowS2 + 1)
Next j
Next i
'copy headers
Sheets("Programming").Range("D1:M1").copy Destination:=Sheets("Equipment").Range("A1:J1")
End Sub
EDIT
Please avoid copying the code from the answer and posting it back at your question, I replaced the Sheet1 with Programming so you can rename that sheet in your workbook.
Macro seems to do what it does, the quantity in Sheet1/Programming was not provided (column "C" according to your initial requirements):
Source (with added quantity)
Result:
Hope this will solve your problem :)
For i = 1 To 30 Step 1
If Sheets("Equipment").Cells(1 + 4, 3).Value > 0 Then
Sheet1.Range(Cells(i + 3, 5), Cells(i + 3, 13)).Copy
For j = 1 To Sheet1.Cells(1 + 4, 3).Value Step 1
LR = Sheets("Programming").Cells(Sheets("Programming").Rows.Count, "A").End(xlUp).Row
Sheets("Programming").Range("A" & LR + 1).PasteSpecial Paste:=xlPasteValues
Next
End If
Next
Cheers ;)
Related
I am working on a code and all I want to do is copy data from one sheet and paste it into another sheet that has a table setup.
My code is doing exactly what I want it to do but, the table doesn't resize to include all the rows that was copied, only the first row of the copied data goes into the table. and the rest are formatted as not in the table.
This is how it looks like after I run the code
Sub LastRowInOneColumn()
Dim LastRow As Longenter image description here
Dim i As Long, j As Long
'Find the last used row in a Column
With Worksheets("First Page")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Report")
j = .Cells(.Rows.Count, "A").End(xlUp).Row '+ 1
End With
For i = 1 To LastRow
With Worksheets("First Page")
'If .Cells(i, 1).Value = "X" Then
.Rows(i).Copy Destination:=Worksheets("Report").range("A" & j)
j = j + 1
'End If
End With
Next i
End Sub
Usually, inserting below the end of the table will make it grow automatically, but not when pasting a range that exceeds the number of columns in the table. There are two ways to deal with this:
1- limit the copied range to the number of columns in the table; i.e.
.Rows(i).Resize(,4).Copy Destination:=Worksheets("Report").range("A" & j)
' ^^^^^^^^^^^
2- Explicitly resizing the table, using the method ListObject.Resize; i.e.
With Sheet1.ListObjects(1)
.Resize .Range.Resize(.Range.Rows.count + 1)
End With
I have been searching on the internet where to find the most efficient and simple way of the following:
I have a spreadsheet that contains 3 sheets:
information
training
Leavers
Within the information sheet, column B contains a validation text that is conditionally formatted. There are two validation options:
Active
Leaver
I want that once the cell value is changed from 'active' to 'Leaver' that the whole row would be removed from the sheet and moved to 'Leaver's sheet.
I have used the code below, it works, however if there is no Leavers it will transfer the first row of 'active'. Can anyone tell me what is the problem?
Sub AlexR688(x)
'For http://www.mrexcel.com/forum/excel-q...ific-text.html
'Using autofilter to Copy rows that contain centain text to a sheet called Errors
Dim LR As Long
Range("B2").EntireRow.Insert Shift:=xlDown
LR = Sheets("Personal Information").Cells(Rows.Count, "B").End(xlUp).Row
LR1 = Sheets("Leavers").Cells(Rows.Count, "B").End(xlUp).Row + 1
With Sheets("Personal Informaiton").Range("B2:C" & LR)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="Leaver", _
Operator:=xlOr, Criteria2:=":Leaver"
.SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=Sheets("Leavers").Range("A" & LR1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End Sub
Secondly, I want to make the same in the 'Training' sheet. But in there, column B, contains the same 'Active', 'Leavers' which is referenced from personal information. So, once the Personal information sheet column B is changed from 'active' to 'leaver', training sheet will change as well, but i want the row in the training sheet would be deleted.
Thirdly, if I accidentally moved row from Personal information sheet to Leavers sheet, is it possible that by selecting back to 'active' cell value the row would move back to where it was?
Thank you very much. Hope it is clear enough.
this is the easiest way
Private Sub imperecheaza_Click()
Dim ws As Worksheet
Dim Rand As Long
Set ws = Worksheets("BD_IR")
Rand = 3
Do While ws.Cells(Rand, 4).Value <> "" And Rand < 65000
If ws.Cells(Rand, 4).Value = gksluri.Value * 1 And ws.Cells(Rand, 5).Value = gksluri.List(gksluri.ListIndex, 1) * 1 Then
ws.Rows(Rand) = "" '(here you will delete entire Row)
gksluri.RemoveItem gksluri.ListIndex
Exit Do
End If
Rand = Rand + 1
Loop
End Sub
Gods of VBA,
I would like to request your help on some code i can't seem to get working straight.
Purpose,
When a row has a cell Value "x" on row A in sheet 'Dump', i would like to past certain values in Sheet 'test'.
The values that need to be posted on Sheet 'test', are in column B, D, F and L.
Value from column B, Sheet 'Dump' should go to D4, in sheet 'test'.
Value from column D, Sheet 'Dump' should go to C4, in Sheet 'test'.
Value from column F, Sheet 'Dump' should go to A4, in Sheet 'test'.
Value from column L, Sheet 'Dump' should go to E4, in Sheet 'test'.
Ofcourse i'm trying to make the VBA loop as that when multiple rows on Sheet 'Dump' contains the character 'x', it continues from D/C/A/E4 to the next row.
The code I already have working is posted here:
Sub test()
Dim i, LastRow
LastRow = Sheets("Dump").Range("A" & Rows.Count).End(xlUp).Row
Sheets("test").Range("A2:K200").ClearContents
For i = 2 To LastRow
If Sheets("Dump").Cells(i, "A").Value = "x" Then
Sheets("Dump").Range(Cells(i, "B"), Cells(i, "B")).Copy
Destination:=Sheets("test").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
End Sub
Have been trying with a lot of different sources of VBA, and some tweaking to it. If i started with a wrong source, or am making some n00b-mistakes, please direct me to what i did wrong. Just trying to learn, while coding.
Tim posted the better way to copy values only but here is what is the problem with your code:
The syntax for copying is
sourceRange.Copy Destination:=destinationRange
The := specifies an option/paramter to the .Copy method. It can be confusing because there are no parentheses around the arguments like you could expect from other languages.
someMethod(argument1, argument2)
would be
someMethod argument1, argument2
if there is nothing else in the line (otherwise you need parentheses).
You can specify what argument you use by naming it and using :=. This is especially useful for optional arguments or to keep your code readable (you might not remember what each argument is in a few months). Some people keep parameters empty but I think it's obvious why something like
someMethod paramName1:=True, paramName4:=False, paramName5:=True
is easier to read than
someMethod True, , , False, True
(I am assuming the parameter names are descriptive like Destination).
The parameters of a function need to be in the same row as the function. To concatenate the rows, remove the linebreak (duh) or place an _ at the end of the line (if it get's to long).
Example with parentheses and linebreaks:
Set someRange = rangeToSearch.Find( _
What:="abc", _
LookIn:=xlValues, _
MatchCase:=True)
Example without parenthesis and linebreaks:
destinationRange.PasteSpecial Paste:=xlPasteValues, skipblanks:=True
You could try the following.
Sub test()
Dim i, LastRow
LastRow = Sheets("Dump").Range("A" & Rows.Count).End(xlUp).Row
Sheets("test").Range("A2:K200").ClearContents
j = 4
For i = 2 To LastRow
If Sheets("Dump").Cells(i, "A").Value = "x" Then
Sheets("test").Cells(j, 4) = Sheets("Dump").Cells(i, 2).Value
Sheets("test").Cells(j, 3) = Sheets("Dump").Cells(i, 3).Value
Sheets("test").Cells(j, 1) = Sheets("Dump").Cells(i, 6).Value
Sheets("test").Cells(j, 5) = Sheets("Dump").Cells(i, 12).Value
j = j + 1
End If
Next i
End Sub
You need a separate way of tracking each row in the test sheet, hence adding j = 4 (because you want to start on row 4).
EDIT
I would define your sheets if you call them a a lot.
Sub test()
Dim i, LastRow, source as Worksheet, dest as Worksheet
Set source = ActiveWorkbook.Sheets("Dump")
Set dest = ActiveWorkbook.Sheets("test")
LastRow = source.Range("A" & Rows.Count).End(xlUp).Row
dest.Range("A2:K200").ClearContents
j = 4
For i = 2 To LastRow
With source
If .Cells(i, "A").Value = "x" Then
dest.Cells(j, 4) = .Cells(i, 2).Value
dest.Cells(j, 3) = .Cells(i, 3).Value
dest.Cells(j, 1) = .Cells(i, 6).Value
dest.Cells(j, 5) = .Cells(i, 12).Value
j = j + 1
End If
End With
Next i
End Sub
I'm new to the community and I apologize if there is a thread elsewhere, but I could not find it!
I'm currently diving into VBA coding for the first time. I have a file that I dump into a worksheet that currently I'm manually organizing and pushing out. When put into the worksheet, it delimits itself across the cells. This dump file will have varying row and column lengths every time I get it in a given day and dump into a work sheet. For example, one day it may be twenty rows and one day it may be thirty.
A certain roadblock in my VBA code creation process has presented itself. I'm trying to create a code that will parse through the worksheet to remove any time a certain value appears (See below image - I'm referring to the (EXT)). After doing so I'm trying to concatenate the cells in the row up until there is a space (which with the rows that have (EXT), there usually isn't a space after until the (EXT) is removed).
The code I made works for now but I recognize it's not very efficient and not reliable if the names extend longer than two cells. I was hoping someone on here could provide me with guidance. So, I'm looking for two things:
For the code to scan the whole active used range of the table and remove (EXT). As it may appear in various columns.
A way to concatenate the cells in every row in the active range from A to the cell before a blank cell
Keep in mind I have no coding background, I'm learning and I'm not familiar with VBA terms and whatnot all that much just yet - so if you could please explain in laymen's terms I'd appreciate it. I hope all of this makes sense... Thanks in advance!
This is just an example of part of what the dump code looks like, so my code probably doesn't match with the example below - I just wanted to provide a visual:
http://i.imgur.com/IwDDoYd.jpg
The code I currently have:
Sub DN_ERROR_ORGANIZER()
' Removes any (EXT) in Column 3 in actual dump data file
For i = 200 To 1 Step -1
If (Cells(i, 3).value = "(EXT)") Then
Cells(i, 3).Delete Shift:=xlToLeft
End If
Next i
' Removes any (EXT) in Column 4 in actual dump data file
For j = 200 To 1 Step -1
If (Cells(j, 4).value = "(EXT)") Then
Cells(j, 4).Delete Shift:=xlToLeft
End If
Next j
' Removes any (EXT) in Column 5 in actual dump data file
For k = 200 To 1 Step -1
If (Cells(k, 5).value = "(EXT)") Then
Cells(k, 5).Delete Shift:=xlToLeft
End If
Next k
' Places a new column before A and performs a concatenate on cells B1 and C1 to
' form a name, then copies all through column A1 to repeat on each row
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "=PROPER(CONCATENATE(RC[1],"", "", RC[2]))"
Range("A1").Select
Selection.AutoFill Destination:=Range("A1:A51")
Range("A1:A51").Select
End Sub
edited: to keep the comma after the first "name" only
this should do:
Sub main()
Dim cell As Range
With Worksheets("names")
With Intersect(.UsedRange, .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).EntireRow)
For Each cell In .Rows
cell.Cells(1, 2).Value = Replace(Replace(Replace(Join(Application.Transpose(Application.Transpose(cell.Value)), " "), " ", " "), " (EXT)", ""), " ", ", ", , 1)
Next cell
.Columns(1).FormulaR1C1 = "=PROPER(RC[1])"
.Columns(1).Value = .Columns(1).Value
.Offset(, 1).Resize(, .Columns.Count - 1).ClearContents
End With
End With
End Sub
just remember to change "names" to you actual worksheet name
edited 2:
code for stopping cells to be processed at every line at the last one before the first blank one
Sub main()
Dim cell As Range, dataRng As Range
With Worksheets("names") '<--| change "names" to you actual worksheet name
Set dataRng = Intersect(.UsedRange, .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).EntireRow)
For Each cell In dataRng.Columns(1).Cells
cell.Offset(, 1).Value = Replace(Replace(Replace(Join(Application.Transpose(Application.Transpose(.Range(cell, cell.End(xlToRight)).Value)), " "), " ", " "), " (EXT)", ""), " ", ", ", , 1)
Next cell
With dataRng
.Columns(1).FormulaR1C1 = "=PROPER(RC[1])"
.Columns(1).Value = .Columns(1).Value
.Offset(, 1).Resize(, .Columns.Count - 1).ClearContents
End With
End With
End Sub
I believe you are quite close to achieve what you are asking for and, based on your request, I will not give you a solution but some guidance to complete it by yourself.
First 3 loops: You could simplify by having a single set of nested loops: An outer loop running from 3 to 5, an inner loop running from 200 to 1; the outer loop will run over index, say "p", the inner over index, say "q", and your reference to cells would become Cells(q,p). If you need to run this over more than 3 rows, just start the outer loop from, say, 3 and till, say 10000 (being 10000 the maximal number of rows your data may display) and add a condition that if the first cell of the row is empty, you exit the outer loop.
The second part (this is what I understood) is to take the 2-3 first cells and concatenate them into a new cell (i.e. the column you add at the left). Once again, you can just loop over all your rows (much the same as in the outer loop mentioned above), except that now you will be looking at the cells in columns 2-4 (because you added a column at the left). The same exit condition as above can be used.
I'm not sure if this is what you were looking for, but this is what I understood you were looking for.
After reading user3598756's answer, I realized that I missed the boat with my original answer.
Sub DN_ERROR_ORGANIZER()
Dim Target As Range
Set Target = Worksheets("Sheet1").UsedRange
Target.Replace "(EXT)", ""
With Target.Offset(0, Target.Columns.Count).Resize(, 1)
.FormulaR1C1 = "=PROPER(C1&"", ""&TEXTJOIN("" "",TRUE,RC[-" & (Target.Columns.Count - 1) & "]:RC[-1]))"
.Value = .Value
End With
Target.Delete
End Sub
UPDATE
If you are running an older version of Excel that doesn't support TEXTJOIN then use this:
Sub DN_ERROR_ORGANIZER()
Dim Data
Dim x As Long, y As Long
Dim Target As Range
Dim Text As String
Set Target = Worksheets("Sheet1").UsedRange
Target.Replace "(EXT)", ""
Data = Target.Value
For x = 1 To Target.Rows.Count
Data(x, 1) = Data(x, 1)
For y = 2 To Target.Columns.Count
If Data(x, y) <> vbNullString Then Text = Text & " " & Data(x, y)
Next
If Len(Text) Then Data(x, 1) = Data(x, 1) & "," & Text
Text = vbNullString
Next
Target.ClearContents
Target.Columns(1).Value = Data
End Sub
I have another question which I hope to resolve with your help.
What do I want to do.
I use Excel to track my work, activities, contacts, et cetera. While doing that I found I was doing a lot of repetitive work in adding rows at the end of a sheet called "Activities".
What I want to do is this:
- Press a button and adding a row.
- Increase the trackingnumber with 1
- Insert default values
The code.
To automate this, I have found (copy, pasted, adjusted it to my needs) the following code:
Sub AddRowActiviteiten_NewAtEnd()
'Add's a new row at the end of the sheet.
Dim wsActiviteiten As Worksheet
Set wsActiviteiten = Sheets("Activiteiten")
DefType = "Daily"
DefStatus = "Open"
DefIssue = "*****"
DefImpact = "*****"
DefPrio = "Laag"
MyDate = Date
wsActiviteiten.Range("A4").Value = "1"
'Copy the "One Row To Rule Them All"
wsActiviteiten.Range("A3:Q3").Copy
wsActiviteiten.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteAll)
'Stop the "copy-action"
Application.CutCopyMode = False
'Increase the tracking number with "one"
LastNumber = wsActiviteiten.Range("A" & Rows.Count).End(xlUp).Value
wsActiviteiten.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = LastNumber + 1
'Insert default values
LastRow = wsActiviteiten.Range("A" & Rows.Count).End(xlUp).Offset(-1, 0).Row
Cells(LastRow + 1, 2) = DefType
Cells(LastRow + 1, 3) = DefStatus
Cells(LastRow + 1, 4) = DefIssue
Cells(LastRow + 1, 5) = DefImpact
Cells(LastRow + 1, 6) = DefPrio
Cells(LastRow + 1, 8) = MyDate
'Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
End Sub
The problem.
In this sheet I open new items, but I also close them. I do this by changing their status and hide them from view. And this is the point where it goes wrong. When I close the last item on the list and want to add a new row, the macro adds a new row below the last visible entry. It does not find the last entry I have just hidden. And also, when this happens, adding the default values to the new row does not work. It adds them at the row above the added one.
Somehow this makes perfect sense. I tell the macro to look for the last entry, but what I don't understand is why it looks at the last visible entry and why it does not look in the hidden rows.
To replicate. Copy the code into a sheet (maybe you need to change the name of the sheet) and add a few lines. Put some info in the last row and hide it. Add another few lines and see what happens.
The solution. Is there a way to resolve this? Maybe there is a smarter way of doing things? I looked into things, but mostly I got results using "("A" & Rows.Count).End(xlUp)". A loop could work, but I am afraid that 1) It does not search through hidden rows and 2) it makes the sheet (somewhat) sluggish. I must say I have tried to make a loop, first I want to see if my first solution is salvageable.
Thank you for your input, if there are any questions please let me know.
Simon
EDIT: Working code for anyone interested
Sub AddRowActiviteiten_NewAtEnd()
'Add's a new row at the end of the sheet.
Dim wsActiviteiten As Worksheet
Set wsActiviteiten = Sheets("Activiteiten")
DefType = "Daily"
DefStatus = "Open"
DefIssue = "*****"
DefImpact = "*****"
DefPrio = "Laag"
MyDate = Date
'Copy the One Row To Rule Them All
wsActiviteiten.Range("A3:Q3").Copy
'Offset(y,x)
'De -16 is een getal dat iets doet, maar ik weet niet wat.
wsActiviteiten.Range(Split(ActiveSheet.AutoFilter.Range.Address, ":")(1)).Offset(1, -16).PasteSpecial (xlPasteAll)
'Stop the "copy-action"
Application.CutCopyMode = False
'Het volgnummer verhogen met 1
'Het laatste getal selecteren (LastNumber) en dan plus 1.
LastNumber = wsActiviteiten.Range(Split(ActiveSheet.AutoFilter.Range.Address, ":")(1)).Offset(0, -16).Value
wsActiviteiten.Range(Split(ActiveSheet.AutoFilter.Range.Address, ":")(1)).Offset(1, -16).Value = LastNumber + 1
'Insert default values
LastRow = wsActiviteiten.Range(Split(ActiveSheet.AutoFilter.Range.Address, ":")(1)).Offset(-1, 0).Row
Cells(LastRow + 1, 2) = DefType
Cells(LastRow + 1, 3) = DefStatus
Cells(LastRow + 1, 4) = DefIssue
Cells(LastRow + 1, 5) = DefImpact
Cells(LastRow + 1, 6) = DefPrio
Cells(LastRow + 1, 8) = MyDate
'Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
End Sub
Update
I see your sheet has an autofilter "hiding" the status rows - which Find wont detect, unlike hidden rows.
Suggest you try this updated code below:
Sub Test()
Dim rng1 As Range
If ActiveSheet.AutoFilterMode Then
MsgBox ActiveSheet.Range(Split(ActiveSheet.AutoFilter.Range.Address, ":")(1)).Row
Else
Set rng1 = Columns("A:A").Find("*", [a1], xlFormulas, , xlByRows, xlPrevious)
If Not rng1 Is Nothing Then MsgBox rng1.Row
End If
End Sub
initial post
If you are hiding rows then you can use Find with the xlFormulas option to find entries in hidden rows (unlike xlValues).
Dim rng1 As Range
Set rng1 = Columns("A:A").Find("*", [a1], xlFormulas, , xlByRows, xlPrevious)
MsgBox rng1.Address
Say we have a status column AB and we currently close an item by placing the word "Closed" in that column and then hiding the row.
Instead:
Unhide all rows
Perform any required inserts and edits
Via a loop, hide all rows marked "Closed"
Use this for getting the last row and it will see the last row, even if it is hidden.
LastRow = wsActiviteiten.UsedRange.Rows.Count
I've just found solution:
If you have at least one column in your range with 'consistent' data (all cells in that column are not empty/blank) you can use formula COUNTA and you can reference you code to value of that COUNTA formula.
For example:
Insert formula '=COUNTA(A1:A100000)' in 'B1' cell.
In B1 you will get how many rows you have they are hidden or not.
In your code change:
wsActiviteiten.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteAll)
to
wsActiviteiten.Range("A" & Range("B1").Value).Offset(1, 0).PasteSpecial (xlPasteAll)
Of course, if, for example, cell 'A2' is blank and this is the only blank cell you will need to adjust your formula to '=COUNTA(A1:A100000) +1'.
If you have more blank/empty cells and you don't know the exact number of them (blank cells have been changed dynamically) this method will not work.
As I said previously you need to have at least one column with 'consistent' data (with known number of empty cells in advance if any).