I'm having trouble with some VBA code and was hoping that someone could help me out.
The problem is with me referencing a specific cell. The code below copies rows into another worksheet and deletes them in the worksheet it took them from based on a value.
The issue is that I want the user to be able to specify the value in a specific cell rather than coming back to a spreadhseet to alter and realter it (it's just a quality of life thing).
Here's the code and what I mean:
Sub Kappa()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Data").UsedRange.Rows.Count
J = Worksheets("Archives").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archives").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Data").Range("I1:I" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Application.Workbooks("Book1.xlsm").Worksheets("Data").Range("M5") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Archives").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = Application.Workbooks("Book1.xlsm").Worksheets("Data").Range("M5") Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True End Sub
What happens with this is that it spins (I couldn't even get an error!).
If you alter the code to say something along the lines of:
Sub Kappa()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Data").UsedRange.Rows.Count
J = Worksheets("Archives").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archives").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Data").Range("I1:I" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Alpha" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Archives").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Alpha" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True End Sub
It works like a charm.
Is there any way of repurposing this so it references a value in a cell?
I am wondering if anyone can help me. I am using a macro to move information from one sheet to another once sold. The problem is that the new sheet has built-in formulas to auto-populate data when items are added. I was wondering if there is a way to still use the macro but have the row be moved over to the new sheet but have it ignore the formulas. Right now it moves the rows to the row after the last formula cell.
The Current code I am using is:
Sub Sold()
'Updated by Kutools for Excel 2017/8/28
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Open Inventory").UsedRange.Rows.Count
J = Worksheets("Sold").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sold").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Open Inventory").Range("H1:H" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Sold" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Sold").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Sold" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
I have the below code which takes rows of data from one worksheet(DataSheet) that has "Actioned" in Column C and should paste it to the next available row on the worksheet (Actioned). The issue at hand is that it doesn't paste it on the next available row, its pasting to Row 2700.
I've cleared contents on all the cells and restarted the workbook but it still doesn't paste it onto the next free row.
can anyone see where I'm going wrong?
Dim xRg As Range
Dim xCell As Range
Dim i As Long
Dim J As Long
Dim K As Long
i = Worksheets("DataSheet").UsedRange.Rows.Count
J = Worksheets("Actioned").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Actioned").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("DataSheet").Range("C2:C" & i)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Actioned" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Actioned").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Actioned" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub ```
I am still a novice at VBA so please bare with my ignorance.
UsedRange can take into account the formatting of empty cells which is not visible to you.
I suggest to use the following method to get the last row of a specific column:
i= Worksheets("DataSheet").Range("C" & Worksheets("DataSheet").Rows.Count).End(xlUp).Row
or:
Dim wsDS As Worksheet: Set wsDS = Worksheets("DataSheet")
Dim iRows As Long
iRows = wsDS.Range("C" & wsDS.Rows.Count).End(xlUp).Row
I have a sheet with some cells are merged in rows, and some are not. I want to wrap all the cells and if rows contains merged cells, set the rows height to max of all cells height
In the excel file, you can find the sheet I am working with, what I want to have, the excel macro I wrote, what I get with that macro. I also put them here.
This is what I have: (column D is a hidden column)
This is what I want to have: (for the rest of the sheet see attached excel file)
I wrote an excel VBA macro to do the job, but there is no luck.
Sub MergeCells2()
Application.DisplayAlerts = False
Dim allRange As Range
Dim xCell As Range
On Error Resume Next
Dim i_row As Integer
Dim nRowsToMerge As Integer
Dim rangeToMerge As Range
Worksheets("What I have").Activate
LastCol = ActiveSheet.Range("a1").End(xlToRight).Column
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, LastCol).End(xlUp).Row
Set allRange = Application.Range("a1", ActiveSheet.Cells(LastRow, LastCol))
allRange.WrapText = True
If allRange Is Nothing Then Exit Sub
nRowsToMerge = 1
Set heightToSet = Range("A2").RowHeight
For i_row = 2 To LastRow
Set i_rowRange = allRange.Rows(i_row - 1)
If (allRange.Cells(i_row, 1) = "") Then
nRowsToMerge = nRowsToMerge + 1
ElseIf nRowsToMerge = 1 Then
heightToSet = i_rowRange.RowHeight
Else
Set rangeToMerge = ActiveSheet.Range(ActiveSheet.Cells(i_row - nRowsToMerge, 1), ActiveSheet.Cells(i_row - 1, LastCol))
For Each xCell In rangeToMerge
cellrow = xCell.Row
If (rangeToMerge.Cells(cellrow, 1) = "") Then
If xCell.Value = "" Then
Range(xCell, xCell.Offset(-1, 0)).Merge
End If
End If
Next
rangeToMerge.RowHeight = heightToSet
heightToSet = i_rowRange.RowHeight
nRowsToMerge = 1
End If
Next i_row
End Sub
This is what I get:
I don't know what is wrong with it and I have to say that I don't know much about VBA programming.
I hope I was clear with my question.
Please help, I am working on this for days now :(
Cheers,
Eda
The idea:
Start by wrapping all cells, and using AutoFit for all rows. This way Excel will automatically set the row height properly.
Loop through the rows merging the cells and dividing the height of the row with the wrapped text over the rows to be merged.
This is how:
Sub NewMerger()
Dim r As Long, rMax As Long, re As Long, cMax As Long, c As Long, n As Long, h As Single, mr As Long
Application.DisplayAlerts = False
'Create a copy of the input
Sheets("What I have").Copy After:=Sheets(Sheets.Count)
On Error Resume Next
Sheets("New Result").Delete
ActiveSheet.Name = "New Result"
'merge and use autofit to get the ideal row height
Cells().WrapText = True
Rows.AutoFit
'get max row and column
cMax = Cells(1, 1).End(xlToRight).Column
rMax = Cells(Rows.Count, 1).End(xlUp).Row
'loop through rows, bottom to top
For r = rMax To 2 Step -1
If Cells(r, 1).Value = "" Then
If re = 0 Then re = r 'If we don't have an end row, we do now!
ElseIf re > 0 Then 'If re has an end row and the current row is not empty (AKA start row)
h = Rows(r).RowHeight 'Get the row height of the start row
n = re - r + 1 'calculate the number of rows
If n > 0 Then Rows(r & ":" & re).RowHeight = h / n 'devide the row hight over all rows
For c = 1 To cMax 'And merge
For mr = re To r Step -1 'Merge only empty cells
If Cells(mr, c).Value = "" Then
Range(Cells(mr, c), Cells(mr - 1, c)).MergeCells = True
End If
Next
Next
re = 0 'We don't have an end row now
End If
Next
Application.DisplayAlerts = True
End Sub
I have 150+ categories and I enter data on excel
Now I need your help.
If I enter any category on Column A excel should check if there is a worksheet naming that category. If yes then it should copy the entire row to the next empty row of that worksheet and if it doesn’t find that worksheet it should create a worksheet naming that category and then copy the entire row to the next empty row of that newly created worksheets. Is it possible?
Thanks a million, in advance for your help.
I use this code to copy entire row to another worksheet is there any way to update it so that it meets my requirements?
Sub CopyRowBasedOnCellValue()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets("Sheet1").UsedRange.Rows.Count
B = Worksheets("Sheet2").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Sheet1").Range("C1:C" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(xRg(C).Value) = "Done" Then
xRg(C).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & B + 1)
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub