I have a matrix of data which contains 16 columns and 300 rows. This data I get it from FORTRAN code. So times I get some blank cells in first column and then that row would have 17 columns. Now I would like to shift the data into blank cells making the matrix uniform.
I am not an expert into VBA. It would be great if you help me with the problem.
So far I have
Sub fillBlanks(Optional ByRef currentSheet As Worksheet)
Dim blanx As Range
If currentSheet Is Nothing Then Set currentSheet = ActiveSheet
currentSheet.Activate
On Error Resume Next
Set blanx = Range("B1", currentSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Address).SpecialCells(xlCellTypeBlanks)
If blanx Is Nothing Then Exit Sub
On Error Goto 0
currentSheet.Range(blanx.Address).FormulaR1C1 = "=RC[1]"
End Sub
Thank you.
Starting with this:
Running this:
Sub dural()
For i = 1 To 15
With Cells(i, 1)
If .Value = "" Then .Delete shift:=xlToLeft
End With
Next i
End Sub
will produce this:
Related
I've been searching and toying with no luck. I'm trying to copy the values (not formulas) from one range n5:n250 to another m5:m250, but I don't want to overwrite any existing values in m if they exist. ie, if m5 is blank, I want my sub to copy what's in n5 to m5. If it's already got a value, I want it left alone.
This is what I've been trying with no luck:
Sub Reconcile()
Dim i As Long
For i = 5 To 250
If Not IsEmpty(Range("M" & i)) Then _
Range("M" & i) = Range("N" & i)
Next i
Worksheets("Master Task List").Range("e5:e58").ClearContents
End Sub
The worksheets line is the second function I'd like the sub to accomplish when I hit the appropriate button.
I would very much appreciate some help.
Thanks!
You can iterate through your rows in column M, and if the value is equal to vbNullString, set the value to the one in column N.
Sub Reconcile()
Dim i As Long
With ThisWorkbook.Worksheets(1)
For i = 5 To 250
If .Cells(i, "M") = vbNullString Then
.Cells(i, "M") = .Cells(i, "N")
End If
Next
End With
End Sub
This is the routine using IsEmpty. Your example you were using Not IsEmpty. When IsEmpty = True, that means that it's empty. With you placing Not in front you are saying Is Not Empty.
Sub Reconcile()
Dim i As Long
With ThisWorkbook.Worksheets(1)
For i = 5 To 250
If IsEmpty(.Cells(i, "M")) Then
.Cells(i, "M") = .Cells(i, "N")
End If
Next
End With
End Sub
Keep in mind, Worksheets(1) is for illustrative purposes. You may need to change this for your specific worksheet.
You could pick out the blank cells and just move those across in a loop.
I've added an On Error Resume Next around setting the range as I don't know of any other way to trap the error that occurs if there are no blank cells.
Sub Reconcile()
Dim rBlanks As Range
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1")
On Error Resume Next
Set rBlanks = .Range("M5:M250").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rBlanks Is Nothing Then
For Each rCell In rBlanks
rCell = .Cells(rCell.Row, "N") 'Could also use 14 or rcell.Offset(,1) in place of "N"
Next rCell
Else
MsgBox "No blanks found."
End If
End With
End Sub
First post all, so forgive any syntax errors: I've been working on a spreadsheet at work for a long time. Its purpose is to log my calls, as I work in a high volume inbound guest services call center. Sometimes I need to follow up with my guests.
Worksheet is Column A:K, starting at Row 5
Ultimately I'm coding a program to check my records, ignore any row that has data in Column K, then when it finds valid data, copy the records to another sheet, and come back to the main sheet. That part works fine and here is the code for that:
Sub Button2_Click()
Dim sourceEmptyRow As Long
Dim targetEmptyRow As Long
Dim sourceRange As Range
Dim targetRange As Range
'Make Today active
Sheet1.Activate
'Set Variables
sourceEmptyRow = FindNextEmpty(Range("K5")).Row
Set sourceRange = Rows(sourceEmptyRow)
sourceRange.Copy
'Activate Next Sheet
sheetQ4.Activate
'Set Variables
targetEmptyRow = FindNextEmpty(Range("A1")).Row
Set targetRange = Rows(targetEmptyRow)
targetRange.PasteSpecial
Sheet1.Activate
sourceRange.Delete Shift:=xlUp
End Sub
Here is the FindNextEmpty() function (which I'm pretty sure I found here)
Public Function FindNextEmpty(ByVal rCell As Range) As Range
'Finds the first empty cell downwards in a column.
On Error GoTo ErrorHandle
With rCell
'If the start cell is empty it is the first empty cell.
If Len(.Formula) = 0 Then
Set FindNextEmpty = rCell
'If the cell just below is empty
ElseIf Len(.Offset(1, 0).Formula) = 0 Then
Set FindNextEmpty = .Offset(1, 0)
Else
'Finds the last cell with content.
'.End(xlDown) is like pressing CTRL + arrow down.
Set FindNextEmpty = .End(xlDown).Offset(1, 0)
End If
End With
Exit Function
ErrorHandle:
MsgBox Err.Description & ", Function FindNextEmpty."
End Function
My PROBLEM is that I'd like to be able to execute this code block, then when its done, check the next row...if BOTH Column A and K are blank to STOP, otherwise Loop back to the top and execute it on the next row. If I have a long day, I can sometimes get 20-30 calls and pushing a button 20-30 times is not efficient.
I have not SERIOUSLY coded since about 2003, so I'm an EXTREME novice.
Thanks for any help, ideas, insight you can provide.
Here is my Spreadsheet
This uses the AutoFilter
Option Explicit
Public Sub MoveCompleted()
Const COL_K = 11
Const TOP_ROW = 5
Dim ws1 As Worksheet: Set ws1 = sheetToday '<--- Source sheet
Dim ws2 As Worksheet: Set ws2 = sheetQ118 '<--- Destination sheet
Dim maxRows As Long, ws1ur As Range
optimizeXL True
With ws1.UsedRange
If ws1.AutoFilterMode Then .AutoFilter
maxRows = .Rows.Count
.Offset(TOP_ROW - 2).Resize(maxRows - (TOP_ROW - 2)).AutoFilter 'ur + header row
.AutoFilter Field:=COL_K, Criteria1:="=" 'show only blanks in K
Set ws1ur = .Offset(TOP_ROW - 1).Resize(maxRows - TOP_ROW + 1, .Columns.Count)
On Error Resume Next
Set ws1ur = ws1ur.SpecialCells(xlCellTypeVisible)
If Err.Number <> 0 Then
Err.Clear
Else
ws1ur.Copy ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
ws1ur.EntireRow.Delete
End If
On Error GoTo 0
.AutoFilter Field:=COL_K
End With
optimizeXL False
End Sub
Public Sub optimizeXL(Optional ByVal settingsOff As Boolean = True)
With Application
.ScreenUpdating = Not settingsOff
.Calculation = IIf(settingsOff, xlCalculationManual, xlCalculationAutomatic)
.EnableEvents = Not settingsOff
End With
End Sub
Initial test sheets
Sheet1
sheetQ4
Result
Sheet1
sheetQ4
I just want to know how to loop through the non blank cells on Column A. What I'm trying to do is copy the contents on [A1:B1] to be added on top of each non blank cells on Column A. So far I have counted the non blank cells on column A but I'm stuck. I know that an Offset function should be used for this.
Here's my code so far:
Dim NonBlank as Long
NonBlank = WorksheetFunction.CountA(Worksheet(1).[A:A])
For i = 1 to NonBlank
[A1:B1].Copy Offset(1,0). "I'm stuck here"
Next i
If you are trying to fill the headers for each Product, try this...
Sub FillHeaders()
Dim lr As Long
Dim Rng As Range
lr = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
On Error Resume Next
Range("A1:B1").Copy
For Each Rng In Range("A3:A" & lr).SpecialCells(xlCellTypeConstants, 2).Areas
If Rng.Cells(1).Value <> Range("A1").Value Then
Rng.Cells(1).Offset(-1, 0).PasteSpecial xlPasteAll
End If
Next Rng
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
As example to simulate the effect of Ctrl-Down from Cell A1 and display the Address, Value in the Immediate Window:
Sub HopToNextNonBlankCellBelow()
Dim oRng As Range
Set oRng = Range("A1")
Debug.Print "Cell Address", "Cell Value"
Do
Set oRng = oRng.End(xlDown)
If Not IsEmpty(oRng) Then Debug.Print oRng.Address(0, 0), oRng.Value
Loop Until oRng.Row = Rows.Count
Set oRng = Nothing
End Sub
Try this... I've (probably) overcounted the rows at 1000, but it likely won't make a difference with your performance. If you wanted to be more precise, there are hundreds of articles on how to find the last row of a range. As for the Offset function, it references a cell in relation to the one we're looping through. In the example below, the code is saying cell.offset(0,1) which means one cell to the right of the cell we are currently looping through. A clearer (less loopy!) example would be if you typed: Range("A10").offset(0,1) it would be the same as typing Range("B10")
Dim Cell As Range
For Each Cell In Range("A2:A1000").Cells
If Not IsEmpty(Cell) Then
Cell.Offset(0, 1).Value = Cell.Value
End If
Next Cell
I am trying to create a code that will run through specific row and if it finds cell with value "1" it adds column next to it and moves on.
I stumbled upon a problem, at this point when my macro finds cell with value 1 it starts adding infinite numbers of columns instead of one and moving to the next cell. Can you help me?
Sub makro()
Set zakres = ActiveSheet.UsedRange
For Each Cell In zakres.Rows(3).Cells
If Cell.Value = 1 Then
Cell.EntireColumn.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next Cell
End Sub
You can try this which will insert columns before any cell with 1 in it.
Edit1: Iterate on Row3 only
Sub Test()
Dim r As Range, c As Range, ir As Range
Dim i As Long
With Activesheet
Set r = .Range("A3", .Cells(3, .Columns.Count).End(xlToLeft))
End With
For i = r.Cells.Count To 1 Step -1
If r.Cells(i).Value = 1 Then r.Cells(i).EntireColumn.Insert xlToRight
Next
End Sub
We used the classic For Loop instead of For Each.
This way we can easily loop backwards. HTH.
I am writing a VBA code that will open a specific worksheet in my workbook in Excel, and then find the cell in Column A that has the value "TOTAL". This then must be set as the ActiveCell, so that the rest of my macro can perform actions on the row containing this cell.
I want it so that when the user runs the macro, this cell is specifically chosen right off the bat. The position of this cell will change after the macro is run, so I need it to work no matter what cell this value is in. Everytime the macro runs, a new row is added above the row containing "TOTAL" and therefore the position of this cell is ever-changing.
So far I have come up with this, just from readin through forums. It still doesn't work, but I'm new to this language and I can't determine where the error is.
Sub Macro2()
Dim C As Range
Worksheets("Project Total").Select
With Selection
C = .Find("TOTAL", After:=Range("A2"), MatchCase:=True)
End With
End Sub
Try this:
Sub Macro2()
Dim cl As Range
With Worksheets("Project Total").Cells
Set cl = .Find("TOTAL", After:=.Range("A2"), LookIn:=xlValues)
If Not cl Is Nothing Then
cl.Select
End If
End With
End Sub
Try this:
Sub activateCellContainingTOTAL()
'Go to the worksheet
Worsheets("Project Total").Activate
'Start going down column A to see if you find the total
dim loopBool as Boolean
loopBool = True
Worksheets("Project Total").Range("A1").Activate
Do While loopBool=True
if Activecell.value = "TOTAL" then
loop = false
else
activecell.offset(1, 0).Activate
end if
loop
End sub
Sub Getvaluesfromeachcolumns()
Dim loopcounter As Integer
Dim loopcounter1 As Integer
Dim dumvalue As String
Dim rrange As Range
dumvalue = Activecell.value 'you can replace your cell reference or any value which you want to search. also you can use input method.'
loopcounter1 = Range("A1:C1").Count
For loopcounter = 1 To loopcounter1
Cells(1, loopcounter).Select
Range(ActiveCell.Address).Select ' to know the active cell and address
Set rrange = Range(ActiveCell.Address, ActiveCell.End(xlDown)).Find(dumvalue)
rrange.Select
Next loopcounter
End Sub