I'm trying to make a macro that will scroll through a spreadsheet an entire row at a time and merge all cells in the active row if they have data. It should do this until the last row.
The code currently sees all rows as empty and therefor skips them, I need an if condition or do until statement that will help detect and skip empty rows, detect rows with data and merge their cells and stop entirely when it reaches the last row.
My current code:
Sub merge()
Dim LastRow As Long, i As Long
Sheets("Body").Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows("1:1").Select
For i = 1 To LastRow
If Range("A" & i).Value = "*" Then
Selection.merge = True
Selection.Offset(1).Select
Else
Selection.Offset(1).Select
End If
Next i
End Sub
I have also tried:
sub merge2()
Dim LastRow As Long, i As Long
Sheets("Body").Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows("1:1").Select
Do Until ActiveCell.EntireRow > LastRow
'this line below was a concept
If ActiveCell.EntireRow & ActiveCell.Column.Value = "*" Then
Selection.merge = True
Selection.Offset(1).Select
Else
Selection.Offset(1).Select
End If
Loop
End Sub
This is untested but should do what you want.
Option Explicit
Sub merge()
Dim ws As Worksheet
Dim LastRow As Integer, i As Integer
Set ws = ThisWorkbook.Sheets("Body")
ws.Activate
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 1 To LastRow
If Not IsEmpty(Range("A" & i)) And ws.Cells(i, Columns.Count).End(xlToLeft).Column > 1 Then
ws.Rows(i & ":" & i).merge
End If
Next i
End Sub
This If will test for a) whether the cell in column A is empty and b) whether there are any other cells in that row. if statement a evaluates to false AND statement b is greater than 1 it will execute the If statement
#Tom I've taken your code and added in an error handler that makes it work without fault, thank you very much for your patience, you've been a fantastic help.
Sub merge2()
Dim ws As Worksheet
Dim LastRow As Integer, i As Integer
Set ws = ThisWorkbook.Sheets("Body")
ws.Activate
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 1 To LastRow
If Not IsEmpty(Range("A" & i)) And ws.Cells(i, Columns.Count).End(xlToLeft).Column >= 1 Then
On Error Resume Next
ws.Rows(i & ":" & i).merge = True
End If
Next i
End Sub
Related
I have written a VBA program to clean up and sort many lines of data on to separate sheets. I am quite happy with it, and it's doing exactly what I need it to do. Unfortunately it can take up to ten minutes to run, as there is around 650,000 lines of data. While stepping through the macros individually, I have determined that the macros that actually search, cut then paste data onto a separate sheet are causing the problem. Does anyone have any tips on what I can do to improve this? I will leave a macro here for you guys to take a look at.
So you know, this is what she does in order: Delete unnecessary data, remove duplicates, sort into separate sheets, then count like addresses.
I have a "RUN" macro that a "Start" button is linked to, to call all macros in the necessary order. In this macro I disable calculation and screen updating, then enable when all macros have completed.
As I mentioned here is one of my sorting macros:
Sub CorpSheet() 'Moves corporate memberships to new sheet
Dim Check As Range, r As Long, lastrow2 As Long, LastRow As Long
'Application.ScreenUpdating = False
LastRow = Worksheets("PASTE DATA HERE").UsedRange.Rows.Count
lastrow2 = Worksheets("Corporate").UsedRange.Rows.Count
If lastrow2 = 1 Then lastrow2 = 0
For r = LastRow To 2 Step -1
If Range("E" & r).Value > 0 Then
Rows(r).Cut Destination:=Worksheets("Corporate") _
.Range("A" & lastrow2 + 1)
lastrow2 = lastrow2 + 1
Else:
End If
Next r
'Application.ScreenUpdating = True
End Sub
Any help that you can provide is appreciated!
Filter the sheet on ColE >0 - copy/paste the remaining rows to Corporate. Then delete the visible rows from the filtered table
Sub Faster()
Dim rngSrc As Range
Set rngSrc = Sheet1.Range("a1").CurrentRegion
rngSrc.AutoFilter Field:=5, Criteria1:=">0"
rngSrc.Copy Sheet2.Cells(Rows.Count, 1).End(xlUp)
rngSrc.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
rngSrc.AutoFilter
End Sub
One thing that would save a lot of time is only doing 1 copy. UNION the rows then copy them to the other sheet and delete them from the original in 1 step:
Sub CorpSheet() 'Moves corporate memberships to new sheet
Dim Check As Range, r As Long, lastrow2 As Long, LastRow As Long
Dim rng As Range
Application.ScreenUpdating = False
LastRow = Worksheets("PASTE DATA HERE").UsedRange.Rows.Count
lastrow2 = Worksheets("Corporate").UsedRange.Rows.Count
If lastrow2 = 1 Then lastrow2 = 0
For r = LastRow To 2 Step -1
If Range("E" & r).Value > 0 Then
If rng Is Nothing Then
Set rng = Rows(r)
Else
Set rng = Union(rng, Rows(r))
End If
End If
Next r
rng.Copy ThisWorkbook.Sheets("Corporate").Range("A" & lastrow2 + 1)
rng.Delete xlUp
Application.ScreenUpdating = True
End Sub
Then you can clean some things up a bit, fully qualify your ranges, and remove some other unnecessary code:
Sub CorpSheet() 'Moves corporate memberships to new sheet
Dim rng As Range
Dim rw As Range
Application.ScreenUpdating = False
For Each rw In Worksheets("PASTE DATA HERE").UsedRange
If rw.Range("E1").Value > 0 Then
If rng Is Nothing Then
Set rng = rw.EntireRow
Else
Set rng = Union(rng, rw.EntireRow)
End If
End If
Next r
rng.Copy ThisWorkbook.Sheets("Corporate").Range("A" & _
Worksheets("Corporate").UsedRange.Rows.Count + 1)
rng.Delete xlUp
Application.ScreenUpdating = True
End Sub
Im trying to write a macro that filters the column F from second to last row to check if the values in the column are numeric and if the length is 5. A diffrent length is allowed if the value in the column G on the same row contains "TEST".If the value doesnt meet the criteria the row should be deleted. The macro seems to work but I need to start it multiple times to filter all the values.
here is the macro:
Sub Makro1()
Dim lrow As Long
lrow = Cells(Cells.Rows.Count, "F").End(xlUp).Row
Dim Rng As Range
Set Rng = Range("F2:F" & lrow)
For Each cell In Rng
If Not IsNumeric(cell) Or (Len(cell) <> 5 And
InStr(UCase(cell.Offset(0, 1).Value), "TEST") = 0) Then
cell.EntireRow.Delete
End If
Next
End Sub
Try this code, it uses backward loop, which is recommended when iterating over colletion, that we delete from:
Sub Makro1()
Dim lrow As Long, i As Long, cellValue As String
lrow = Cells(Rows.Count, "F").End(xlUp).Row
For i = lrow To 2 Step -1
cellValue = Cells(i, "F").Value
If Not (IsNumeric(cellValue) And Len(cellValue) = 5) And Cells(i, "G").Value = "TEST" Then
Rows(i).Delete
End If
Next
End Sub
I have a macro that looks for records in Column B and if there is a value in a cell within that column then the macro will add a value to Column A in the same row. My problem occurs when Column B has NO values in it whatsoever. The macro just continues running endlessly in those instances. What I am looking for is a way to say:
If Column B contains NO value then skip to the next macro.
I know this involves an IF statement of some kind I just can not figure out how to add that logic into my existing code.
My code:
Sub Update_Column_Based_On_Column_Value_1()
On Error Resume Next
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=If(LEN(RC2),""NEW VALUE GOES HERE"", TEXT(,))"
.Range("A1:A" & lRow).Value = .Range("A1:A" & lRow).Value
End With
End Sub
My search for the answer yielded this string of code from another StackOverflow question:
If WorksheetFunction.CountBlank(emailRng) = emailRng.Cells.Count Then Exit Sub 'No data
When I added that to my code it simply ended the sub if there were ANY blank cells in a column.
Thanks in advance for the assistance! I do apologize if my question is overly noobish.
Try this:
Sub Update_Column_Based_On_Column_Value_1()
On Error Resume Next
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
' This will count all non-blanks in Column B, I put equal to 1
' because I am assuming B1 is a header with a title so it will at minimum be 1
If WorksheetFunction.CountA(ws.Range("B:B")) = 1 Then
' if count is equal to 1 then this part will run
' so enter name of the sub() or write new code in here
Else
' if not less than or equal, meaning greater than 1
' then the following code below will run
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=If(LEN(RC2),""NEW VALUE GOES HERE"", TEXT(,))"
.Range("A1:A" & lRow).Value = .Range("A1:A" & lRow).Value
End With
End If
This code will do what you want
Sub test()
Dim i As Long
Dim lRow As Long
lRow = Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lRow
If Cells(i, "B").Value <> vbNullString Then
Cells(i, "A").Value = Cells(i, "B").Value
End If
Next i
End Sub
I don't know why I am having the hardest time with this. I am just trying to copy a single row from sheet1 to the next available row on sheet2. I have to row copied but it just wont paste without giving me error. This is my copy and it is working.
ws1.Rows(j).EntireRow.Copy
Following should be helpful
Sub Demo()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow As Long, j As Long
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To 10 'change loop as required
If (your_condition) Then
lastRow = lastRow + 1
ws1.Rows(j).EntireRow.Copy ws2.Range("A" & lastRow)
End If
Next j
End Sub
Try this:
Code Sample:
Sheets("Sheet1").Cells(i, "A").EntireRow.Copy Destination:=Sheets("Sheet 2").Range("A" & Rows.Count).End(xlUp).Offset(1)
You may use the below code
Sub CopyPaste()
Sheet1.Range("A:A").Copy
Sheet2.Activate
col = 1
Do Until Sheet2.Cells(1, col) = ""
col = col + 1
Loop
Sheet2.Cells(1, col).PasteSpecial xlPasteValues
End Sub
I have found the code
Sub Test()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows,SearchDirection:=xlPrevious).Row
Dim lColumn As Long
Dim x As Long
Dim rng As Range
For Each rng In Range("A1:A" & LastRow)
lColumn = Cells(rng.Row, Columns.Count).End(xlToLeft).Column
For x = 1 To lColumn - 2
Range(Cells(rng.Row, "A"), Cells(rng.Row, "B")).Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = rng.Offset(0, x + 1)
Next x
Next rng
Application.ScreenUpdating = True
End Sub
I am trying to modify it to suit my needs but it isn't quite doing what I need it to do.
Basically, my table is like this:
A B C D
FILENAME ID FIELD1 FIELD2
1 2 3 4
and I want it to look like this:
A FILENAME 1
B ID 2
C FIELD1 3
D FIELD2 4
however, sometimes there may be more columns or rows associated with a given part of the range that is related to a set of data. right now the columns that
I don't know nearly enough about excel and vba to modify this code to do that, but it would be nice if I could.
below are a couple of links that explain closely how I want the final table to look.
http://pastebin.com/1i5MqTL7
http://imgur.com/a/PKAcy
The ID's are not unique product pointers, but that's the REAL world. Different considerations and assumptions about the consistency of your input data, but try this:
Private Sub TransposeBits()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
'start will be the starting row of each set
Dim start As Long
start = 2
'finish will be the last row of each set
Dim finish As Long
finish = start
Dim lastRow As Long
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'printRow will keep track of where to paste-transpose each set
Dim printRow As Long
printRow = lastRow + 2
'lastCol will measure the column count of each set
Dim lastCol As Long
'Just dealing with a single entry here - delete as necessary
If lastRow < 3 Then
lastCol = Cells(start, 1).End(xlToRight).Column
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
Application.ScreenUpdating = True
'in the trivial case, we can exit the sub after dealing with the one-line transpose
Exit Sub
End If
'more general case
For i = 3 To lastRow
If Not Range("A" & i).Value = Range("A" & i - 1).Value Then
'the value is different than above, so set the finish to the above row
finish = i - 1
lastCol = Cells(start, 1).End(xlToRight).Column
'copy the range from start row to finish row and paste-transpose
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
'after finding the end of a set, reset the start and printRow variable
start = i
printRow = printRow + lastCol
End If
Next i
'here we deal with the last set after running through the loop
finish = lastRow
lastCol = Cells(start, 1).End(xlToRight).Column
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
Application.ScreenUpdating = True
End Sub
You can use the Paste Special that #Jeeped uses - just write it in code:
Sub TransposeData()
Dim rLastCell As Range
With ThisWorkbook.Worksheets("Sheet1")
'NB: If the sheet is empty this will throw an error.
Set rLastCell = .Cells.Find("*", SearchDirection:=xlPrevious)
'Copy everything from A1 to the last cell.
.Range(.Cells(1, 1), rLastCell).Copy
'Paste/Transpose in column A, one row below last row containing data.
.Cells(rLastCell.Row + 1, 1).PasteSpecial Transpose:=True
End With
End Sub