I would like to write a code in VBA which copies formula from range("A3:H3") to these columns until there is data in column J. I've tried this code:
Sub fill_up()
If Not IsNull(Range("J3:J30000")) Then
Range("A3:H3").Select
Selection.Copy
Range("A4:H30000").PasteSpecial xlPasteFormulas
End If
End Sub
But this way I get filled up the columns until the 30000. row anyways.
Another code I wrote for a command button:
Private Sub CommandButton1_Click()
Dim i As Integer
Dim j As Integer
i = 3
j = 4
If Not IsEmpty(Cells(i, 9)) Then
Range("A3:H3").Select
Selection.Copy
Cells(j, 1).PasteSpecial xlPasteFormulas
Do until j > 30000
i = i + 1
j = j + 1
Loop
End If
End Sub
But here the formula is only pasted to the 4. row.
Any suggestions?
Something like this:
sub test1()
iRow = 5
Do Until not IsEmpty(cells(iRow,10))
Range(cells(3,1), cells(3,8)).Copy
Range(cells(iRow,1), cells(iRow,8)).PasteSpecial Paste:=xlPasteFormulas
iRow = iRow + 1
Loop
End Sub
That won't copy anything into the row that contains data in col J. If you want to include that row for pasting, then you could add a further single paste op after the do loop as a quick 'n' dirty fix.
I recommend referencing the last cell containing data using ActiveSheet.Usedrange.Rows.Count property.
In your case:
Range("A4:H" & ActiveSheet.UsedRange.Rows.Count)
Related
Need packing list details by each carton. If a row have details which same for 4 cartons, need to copy & paste same raw 3 times above.
If H Column have 4, then I am using below VBA to command to type in 3. And same row copy and paste 3 times below.
But I want automate this process. So I don't have type in how many times need to be copy and paste for each row. I am newbie, new help will be appreciated.
Sub copy_paste2()
Dim i As Integer
i = Application.InputBox("How many copies?", Type:=1)
ActiveCell.Offset(1).Resize(i).EntireRow.Insert
ActiveCell.Offset(1).Resize(i).EntireRow.Value = ActiveCell.EntireRow.Value
End Sub
Scan up the sheet so inserting rows does not affect the row iterator.
Option Explicit
Sub copy_paste2()
Const COL_QU = "H"
Dim lastrow As Long, r As Long, n As Long, q
Application.ScreenUpdating = False
With ActiveSheet
lastrow = .Cells(.Rows.Count, COL_QU).End(xlUp).Row
For r = lastrow To 2 Step -1
'quantity
q = .Cells(r, COL_QU)
If Len(q) > 0 And IsNumeric(q) Then
If q > 1 Then
.Rows(r).Copy
.Rows(r).Resize(q - 1).Insert shift:=xlDown
n = n + q - 1
End If
End If
Next
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox n & " rows inserted", vbInformation
End Sub
I have what I thought would be a simple script, but I have some some strange results.
Goal: Identify specific IDs in a SOURCE sheet using a list of IDs on a Translator Sheet. When found, copy the entire row to and OUTPUT sheet.
The output has strange results that I can't figure out.
Returns all results instead of the limited list. AND results are in weird groupings. (First result is on row 21 and only has 9 rows of data, the next group has 90 rows of data, starting on row 210, then blank rows, then 900 rows of data, etc.
Results do not start in row 2.
Full code is below attempts:
Attempts:
I first searched the SOURCE sheet based on one ID that was hard coded as a simple test and it worked. but when I changed the code to search a range (z21:z), two things happened: 1, it returns everything in the Source file in multiples of 9 as stated above, AND as you can imagine, the time to complete skyrocketed from seconds to minutes. I think I missed a add'l section of code to identify the range??
Old Code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("D62D627EB404207DE053D71C880A3E05") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
New code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I)** Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
1a. I believe one issue is that the Translator list has duplicates. Second, it is searching the entire column Z. Second issue may be that The list in Translator is generated via a formula in column Z, thus if the formula is false, it will insert a "" into the cell. I seek the code to NOT paste those rows where the cell content is either a "" or is a true blank cell. Reason: The "" will cause issues when we try to load the Output file into a downstream system because it is not a true blank cell.
Results in wrong location: When the script is complete, my first result does not start on Row 2 as expected. I thought the clear contents would fix this, but maybe a different clear function is required? or the clear function is in the wrong place? Below screenshot shows how it should show up. It is in the same columns but doesn't start until row 21.
enter image description here
Slow code: I have a command that copies and pastes of the first row from SOURCE to OUTPUT. My code is cumbersome. There has to be an easier way. I am doing this copy and paste just in case the source file adds new columns in the future.
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Thank you for all your help.
Option Explicit
Sub MoveRowBasedOnCellValuefromlist()
'Updated by xxx 2023.01.18
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("SOURCE").UsedRange.Rows.Count
J = Worksheets("Output").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Output").UsedRange) = 0 Then J = 0
End If
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Set xRg = Worksheets("SOURCE").Range("B2:B" & I)
On Error Resume Next
Application.ScreenUpdating = False
'NOTE - There are duplicates in the Translator list. I only want it to paste the first instance.
'Otherwise, I need to create an =Unique() formula and that seems like unnecessary work.
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I) Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Try this out - using Match as a fast way to check if a value is contained in your lookup list.
Sub MoveRowBasedOnCellValuefromlist()
Dim c As Range, wsSrc As Worksheet, wsOut As Worksheet, wb As Workbook
Dim cDest As Range, wsTrans As Worksheet, rngList As Range
Set wb = ThisWorkbook 'for example
Set wsSrc = wb.Worksheets("SOURCE")
Set wsOut = wb.Worksheets("Output")
Set wsTrans = wb.Worksheets("Translator")
Set rngList = wsTrans.Range("Z21:Z" & wsTrans.Cells(Rows.Count, "Z").End(xlUp).Row)
ClearSheet wsOut
wsSrc.Rows(1).Copy wsOut.Rows(1)
Set cDest = wsOut.Range("A2") 'first paste destination
Application.ScreenUpdating = False
For Each c In wsSrc.Range("B2:B" & wsSrc.Cells(Rows.Count, "B").End(xlUp).Row).Cells
If Not IsError(Application.Match(c.Value, rngList, 0)) Then 'any match in lookup list?
c.EntireRow.Copy cDest
Set cDest = cDest.Offset(1) 'next paste row
End If
Next c
Application.ScreenUpdating = True
End Sub
'clear a worksheet
Sub ClearSheet(ws As Worksheet)
With ws.Cells
.ClearContents
.ClearFormats
End With
End Sub
I want to copy some data from 2 columns ("Nastavit D" sheet, column Q2 to R1000) to the end of the columns with similar data on another sheet ("Chain" sheet, column A1 to B1000). I have a code for this, but I need improvement so that it copies the border formats too. Also, If cell C3 in sheet called "Nedotykat sa!!!" is TRUE, then I want it to copy the data to Sheet called "Chain" BEFORE any other data (basically putting in it A1, "pushing" the existing data there down below the new copied data), instead of putting it to the end. I have a code for copying and putting the data into the end of "Chain" sheet.
Sub CopyRange()
Dim x, y(), I As Long, ii As Long
If Sheets("Nastavit D").[Q2] = "" Then Exit Sub
x = Sheets("Nastavit D").[Q2:R1000]
For I = 1 To UBound(x, 1)
If x(I, 1) <> "" Then
ReDim Preserve y(1 To 2, 1 To I)
For ii = 1 To 2
y(ii, I) = x(I, ii)
Next
Else: Exit For
End If
Next
With Sheets("Chain")
.Cells(.rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(y, 2), 2) = Application.Transpose(y)
End With
End Sub
EDIT:
I started to rewrite the whole VBA code based on suggestions by #BigBen and #Jeff. However, for now, it copies the whole range of Q2:R1000, even blank cells, because they contain formulas I think. How can I copy only cells with actual values, even if it contains formulas?
Sub CopyRangeUpdated()
Dim lastRow As Long
lastRow = Sheets("Chain").Range("A65536").End(xlUp).Row + 1
If Sheets("Nastavit D").[Q2] = "" Then Exit Sub
Sheets("Nastavit D").Range("Q2:R1000").Copy
Sheets("Chain").Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues, SkipBlanks:=True
'clear clipboard
Application.CutCopyMode = False
End Sub
Here is a sample code for #BigBen's suggestion
Edited in response to question edit
The skip blanks not compress what is copied to remove blanks, it will just "skip over" them. for example:
1 A
_ B
3 C
pasting col1 onto col2 will result in:
1
B
3
'copy range
Sheets("Nastavit D").Range("Q2:R1000").Copy
'paste values
Sheets("Chain").Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
'clear clipboard
Application.CutCopyMode = False
'copy formatting
Sheets("Nastavit D").Range("Q2:R1000").Copy
'paste formatting
Sheets("Chain").Range("A1").PasteSpecial xlPasteFormats
To "push data down", I would insert cells beforehand:
Sheets("Chain").Rows("2:1001").insert Shift:=xlDown
Then delete blank rows with something like this (the i is there to prevent an infinite loop if the last row is blank)
i=2
for x = 2 to 1001
if i<10001 then
if sheet("Chain").Range("A"&x).text = "" then
Sheet("Chain").Range("A"&x).entirerow.delete xlshiftup
'if say row2 is deleted, need to re-check row2 new value
x = x-1
end if
else
exit for
end if
i=i+1
next x
I am trying to write a code that adds in data from my excel sheet if the item the user selects is equal to the range in J. This works perfectly if the range in J is filled in with all the data, but how do I get the row to still count all the way through the last filled cell if there are blanks in between? I attached a picture to show what I mean.
.
I would want to count the rows all the way down to the last "Gold". Right now it only counts to the second.
Private Sub cboName_Click() 'only get values that are assigned
Dim j As Integer, k As Integer, i As Integer
Me.lstProvider.Clear
i = 0
Worksheets("Biopsy Log").Select
For j = 1 To Range("J2", Range("J1").End(xlDown)).Rows.count
If Range("J2", Range("J2").End(xlDown)).Cells(j) = Me.cboName.Value Then
If Range("C2", Range("C2").End(xlDown)).Cells(j) = "Assigned" Then
With Me.lstProvider
.AddItem
For k = 0 To 5
.List(i, k) = Range("A" & j + 1).Offset(0, k)
Next
End With
i = i + 1
End If
End If
Next
End Sub
Instead of For j = 1 To Range("J2", Range("J1").End(xlDown)).Rows.count use Range("J" & Rows.Count).End(xlUp).Row (assuming GOLD is in column J). The code does the opposite of xlDown. It goes down to the last row of the sheet (Rows.count) and moves up until it find the first non-blank cell.
Instead of using xlDown, try to use xlUp from the bottom to get the last row for correct range:
Dim sht As Worksheet
Set sht = Worksheets("Biopsy Log")
For j = 1 To sht.Range("J" & sht.Rows.Count).End(xlUp).Row
If sht.Range(...)
Qualifying Range calls with an explicit Worksheet object makes your code more robust.
I'm currently looking for a code to improve my Dashboard. Actually, I need to know how to use a loop in a column X who will affect a column Y (cell on the same line).
To give you an example:
Column A: I have all Production Order (no empty cell)
Column B: Cost of goods Sold (Sometimes blank but doesn't matter)
I actually pull information from SAP so my Column B is not in "Currency".
The action should be:
If A+i is not empty, then value of B+i becomes "Currency".
It's also for me to get a "generic" code that I could use with other things.
This is my current code...
Sub LoopTest()
' Select cell A2, *first line of data*.
Range("A2").Select
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Style = "Currency"
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Another example, getting Last Row, in case your data contains any blank rows.
Sub UpdateColumns()
Dim wks As Worksheet
Dim lastRow As Long
Dim r As Long
Set wks = ActiveSheet
lastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For r = 2 To lastRow
If wks.Cells(r, 1) <> "" Then
wks.Cells(r, 2).NumberFormat = "$#,##0.00"
End If
Next r
End Sub
I can see I was a little slower than the others, but if you want some more inspiration, heer is a super simple solution (as in easy to understand as well)
Sub FormatAsCurrency()
'Dim and set row counter
Dim r As Long
r = 1
'Loop all rows, until "A" is blank
Do While (Cells(r, "A").Value <> "")
'Format as currency, if not blank'
If (Cells(r, "B").Value <> "") Then
Cells(r, "B").Style = "Currency"
End If
'Increment row
r = r + 1
Loop
End Sub
Try the following:
Sub calcColumnB()
Dim strLength As Integer
Dim i As Long
For i = 1 To Rows.Count
columnAContents = Cells(i, 1).Value
strLength = Len(columnAContents)
If strLength > 0 Then
Cells(i, 2).NumberFormat = "$#,##0.00"
End If
Next i
End Sub
Explanation--
What the above code does is for each cell in Column B, so long as content in column A is not empty, it sets the format to a currency with 2 decimal places
EDIT:
Did not need to loop
Here's a really simply one, that I tried to comment - but the formatting got messed up. It simply reads column 1 (A) for content. If column 1 (A) is not empty it updates column 2 (B) as a currency. Changing active cells makes VBA more complicated than it needs to be (in my opinion)
Sub LoopTest()
Dim row As Integer
row = 1
While Not IsEmpty(Cells(row, 1))
Cells(row, 2).Style = "Currency"
row = row + 1
Wend
End Sub