I am trying to copy rows that contain data (in cells A, B, C, D) down into the same cells (in the different rows) if the cells are blank. So basically copying the data in the above cells if the preceding cells are empty. The code I have is as follows:
Sub PadOut()
With Range("A2:D300") ' change this
On Error Resume Next
Set aRange = .SpecialCells(xlCellTypeBlanks) 'check for blank cells
On Error Goto 0
If Not aRange Is Nothing Then
aRange.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End If
End With
End Sub
Currently I have it at a set range.. But how can I set so as the range can be expanded (if I didn't know the number of total rows)
Is this what you're trying to achieve? You can change the start row and column number as neccessary. The endCol variable defines the last colulmn to scan through and the endRow loop finds the last used row in the defined column range.
Sub PadOut()
Application.ScreenUpdating = False
Dim startRow As Long
startRow = 2
Dim startCol As Long
startCol = 1
Dim endCol As Long
endCol = 3
With ActiveSheet
Dim row As Long
Dim col As Long
Dim endRow As Long
Dim bottomRow As Long
bottomRow = ActiveSheet.Rows.Count
Dim colEndRow As Long
endRow = 0
For col = startCol To endCol
If (Cells(bottomRow, col).End(xlUp).row > endRow) Then
endRow = Cells(bottomRow, col).End(xlUp).row
End If
Next col
For col = startCol To endCol
For row = startRow + 1 To endRow
If .Cells(row, col).value = "" Then
.Cells(row, col).value = .Cells(row - 1, col).value
End If
Next row
Next col
End With
Application.ScreenUpdating = True
End Sub
Sub PadOut()
lastRow = ActiveSheet.UsedRange.Rows.Count
if cells(lastRow, 1) = "" and cells(lastRow, 2) = "" and cells(lastRow, 3) = "" and cells(lastRow, 4) = "" then
lastRow = WorksheetFunction.Max(cells(lastRow, 1).end(xlup).row, cells(lastRow, 2).end(xlup).row, cells(lastRow, 3).end(xlUp).row, cells(lastRow, 4).end(xlup).row)
end if
With Range("A2:D" & lastRow)
On Error Resume Next
Set aRange = .SpecialCells(xlCellTypeBlanks) 'check for blank cells
On Error Goto 0
If Not aRange Is Nothing Then
aRange.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End If
End With
End Sub
You can get the total number of rows using the following:
numberRows = ActiveSheet.UsedRange.Rows.Count
Then you can set up the range accordingly.
You don't really need VBA for this task.
It can be accomplished with use of the selection page and array filling.
To do this:
Highlight your range, starting with the first row and cell that has blank data you are interested in filling.
Next, press CTRL+G, this will display the "Go To" window, press Special.... Select the "blanks" option and press OK.
This will select all BLANK cells in your range. Then, without clicking (or you will change your selection), type: = {Press UP arrow} then press CTRL + ENTER
Your Data Before // Your Data After
Related
I have 2 sheets. Sheet1 has 2 rows: column names and values.
Sheet 2 is a master sheet with all the possible column names in. I need to copy the values from sheet 1 into their appropriate column.
I think i can do this via a match function, and so far i have this:
Sub dynamic_paste()
Dim Columnname As String
Dim inputvalue As String
Dim starter As Integer
Dim i As Integer
starter = 0
For i = 1 To 4
'replace 4 with rangeused.rows.count?
Sheets("sheet1").Select
Range("a1").Select
ActiveCell.Offset(0, starter).Select
Columnname = ActiveCell
'sets columnname variable
ActiveCell.Offset(1, 0).Select
inputvalue = ActiveCell
'sets inputname variable
Sheets("sheet2").Select
'**Cells(0, WorksheetFunction.Match(Columnname, Rows(1), 0)).Select**
Range("a1").Offset(1, starter).Value = inputvalue
'inputs variable in the next cell along
starter = starter + 1
Next
End Sub
I need to find out how to use my columnname variable as the matching value, and then offset down to the first row that is empty - then change the value of that cell to the variable called inputvalue.
For extra points: I need to make sure the code doesnt break if they dont find a matching value, and if possible put any values that dont match into the end of the row?
What about this:
Dim LR As Long, X As Long, LC As Long, COL As Long
Dim RNG As Range, CL As Range
Option Explicit
Sub Test()
LR = Sheets(2).Cells.SpecialCells(xlCellTypeLastCell).Row 'Get last used row in your sheet
LC = Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column 'Get last used column in your sheet
Set RNG = Sheets(2).Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, LC))
'Loop through all the columns on your sheet with values
For X = 1 To Sheets(1).Cells(1, Sheets(1).Columns.Count).End(xlToLeft).Column
Set CL = RNG.Find(Sheets(1).Cells(1, X).Value, lookat:=xlWhole)
If Not CL Is Nothing Then
COL = CL.Column
Sheets(2).Cells(LR + 1, COL).Value = Sheets(1).Cells(2, X).Value 'Get the value on LR offset by 1
Else
Sheets(2).Cells(1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(1, X).Value
Sheets(2).Cells(LR + 1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(2, X).Value
End If
Next X
End Sub
This way you will avoid using select. Which is very recommandable!
This is Sheet1:
This is Sheet2:
This is the code:
Option Explicit
Sub DynamicPaste()
Dim col As Long
Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
For col = 1 To 3
Dim currentRow As Long
currentRow = WorksheetFunction.Match(wks2.Cells(1, col), wks1.Columns(1))
wks2.Cells(2, col) = wks1.Cells(currentRow, 2)
Next col
End Sub
This is Sheet2 after the code:
This is a must-read - How to avoid using Select in Excel VBA
I would like to write a UDF (user defined function, aka. macro) that will be used in each of the green cells. In this function/macro in want to get the length of the longest string in the framed cells next to my current group of green cells. In order to do this in the macro I need to determine a range that represents all of the framed cells next to the current cell. (This calculation should result the same range object for each cell in one green group but a different one from group to group.) How would you get this Range?
My first try was this:
Range(Application.Caller.Offset(0, -1).End(xlUp),_
Application.Caller.Offset(0, -1).End(xlDown))
But this
doesn't work
would give false range if the caller cell is the uppermost or lowermost cell of a group.
I would need something like ActiveCell.Offset(0, -1).CurrentRegion, but in the vertical direction only.
Try this:
Function findlongest()
Dim fullcolumn() As Variant
Dim lastrow As Long
Dim i As Long, j As Long, k As Long
Dim tmax As Long
tmax = 0
With Application.Caller
lastrow = .Parent.Cells(.Parent.Rows.Count, .Column - 1).End(xlUp).Row
fullcolumn = .Parent.Range(.Parent.Cells(1, .Column - 1), .Parent.Cells(lastrow, .Column - 1)).Value
For j = .Row To 1 Step -1
If fullcolumn(j, 1) = "" Then
j = j + 1
Exit For
ElseIf j = 1 Then
Exit For
End If
Next j
For i = .Row To UBound(fullcolumn, 1)
If fullcolumn(i, 1) = "" Then
i = i - 1
Exit For
ElseIf i = UBound(fullcolumn, 1) Then
Exit For
End If
Next i
'to get the range
Dim rng As Range
Set rng = .Parent.Range(.Parent.Cells(j, .Column - 1), Parent.Cells(i, .Column - 1))
'then do what you want with rng
'but since you already have the values in an array use that instead.
'It is quciker to iterate and array than the range.
For k = j To i
If Len(fullcolumn(k, 1)) > tmax Then tmax = Len(fullcolumn(k, 1))
Next k
findlongest = tmax
End With
End Function
Are you after something like the code below:
Option Explicit
Sub GetLeftRange()
Dim myRng As Range
Set myRng = ActiveCell.Offset(, -1).CurrentRegion
Debug.Print myRng.Address
End Sub
Note: ActiveCell is one of the cells you marked as green.
This is an example of setting each range using Area.
Sub test()
Dim Ws As Worksheet
Dim rngDB As Range
Dim rngA As Range, rng As Range
Set Ws = ActiveSheet
With Ws
Set rngDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
Set rngA = rngDB.SpecialCells(xlCellTypeConstants, xlTextValues)
For Each rng In rngA.Areas
rng.Offset(, 1).Select '<~~ select is not required but is intended to be visualized
Next rng
End With
End Sub
I have some spreadsheet data that will be in multiples columns but the number of columns will vary from 1 to 8 based on the number of entries. I have some entries that start with the same 2 characters in this format: CF 12456 There could be only 1 of these or many of these "CF 12345"s Once the data is spread out into evenly distributed columns, I need to move all the cells with a "CF 12345" into a new column that will be the last column of data (i.e. if there are 6 columns of data, the "CF 12345" column should be to the right of column 6). This code does all of that except it moves all the "CF 12345"s to column I (yes, I know its because that is what the code is telling it to do). Here is the code:
Sub DiscrepancyReportMacroStepTwo()
'Step 4: Find CF cells move to the top of their own column
Dim rngA As Range
Dim cell As Range
Set rngA = Sheets("Sheet1").Range("A2:H500")
For Each cell In rngA
If cell.Value Like "*CF*" Then
cell.Copy cell.Offset(0, 1)
cell.Clear
End If
Next cell
End Sub
Iterate on the columns of the used range and for each found cell matching the pattern, swap its value with the top cell. If you need to keep all the cell values, you need to track the current top row where you need to swap.
By the way, your pattern seems to be "CF *", not "*CF*", unless you made a mistake in the problem description. This code will move all your CF * cells to the top while preserving all values existing in the worksheet.
Sub DiscrepancyReportMacroStepTwo()
Dim cel As Range, col As Range, curRow As Long, temp
For Each col In Sheets("Sheet1").UsedRange.Columns
curRow = 1
For Each cel In col.Cells
If cel.Value2 Like "CF *" Then
' Swap values of the cell and a cel from top of the column (at curRow)
temp = col.Cells(curRow).Value2
col.Cells(curRow).Value2 = cel.Value2
cel.Value2 = temp
curRow = curRow + 1
End If
Next cel
Next col
End Sub
EDIT
The above code moves the CF * cells to the top of the column. To add them in a new separate column, use this:
Sub DiscrepancyReportMacroStepTwo()
Dim lastColumn As Long, lastRow As Long, cel As Range, curRow As Long
With Sheets("Sheet1")
lastColumn = .Cells.Find("*", , xlFormulas, xlPart, xlByColumns, xlPrevious).Column
lastRow = .Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).row
For Each cel In .Range("A2", .Cells(lastRow, lastColumn))
If cel.Value2 Like "CF *" Then
curRow = curRow + 1
.Cells(curRow, lastColumn + 1).Value2 = cel.Value2
cel.Clear
End If
Next cel
End With
End Sub
You can use a regular expression to look for the 'CF *' values which will ensure that you select only values that start with 'CF ' followed by 5 digits as per your problem statement. If you don't know the # of digits but know it'll be between 2 and 5 digits, you can change the regular expression pattern to: "^CF [\d]{2,5}$"
Option Explicit
Sub Move2LastCol()
Dim sht As Worksheet
Set sht = Worksheets("Sheet1")
Dim regEx As Object
Set regEx = CreateObject("vbscript.regexp")
regEx.Pattern = "^CF [\d]{5}$"
Dim r As Integer, c As Integer, lastRow As Integer, lastCol As Integer
Dim tmp As String
With sht
lastCol = .Cells.Find(What:="*", SearchOrder:=xlColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column + 1
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For r = 1 To lastRow:
Dim c1 As Integer: c1 = lastCol
For c = 1 To .Cells(r, lastCol).End(xlToLeft).Column:
If regEx.Test(.Cells(r, c)) Then
tmp = .Cells(r, c).Value2
.Cells(r, c).Clear
.Cells(r, c1).Value2 = tmp
c1 = c1 + 1
Exit For
End If
Next
Next
End With
End Sub
I am attempting to use VBA to fill all blank cells in rows with the value to the left, with the exception that I only want to fill the blank cells between the first and last value in the row (not including row 1 and column A, which are identifiers).
I've struggled with getting the loop to stop once the last column with a value has been reached (as this changes with each row), rather than running all the way through the last column on the sheet.
Originally this was marked as duplicate (Autofill when there are blank values), but this does not solve the mentioned problem. This continues until the sheet ends. As seen in the picture below, the fill should stop when the last value is reached.
I am searching for a solution that will allow me to do this for an entire sheet at once, even though the data ends in different columns throughout the sheet. There are 1000+ rows, so running for each row could be quite tedious.
I've been using this code to fill the data (excluding the 1st row and column). But this is where I am not sure how to get it to stop at the last value in the row.
Sub test()
With ThisWorkbook.Sheets("Sheet1").Range("A:A")
With Range(.Cells(2, 2), .Cells(.Rows.Count, 36).End(xlUp))
With .Offset(0, 1)
.Value = .Value
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=RC[-1]&"""""
On Error GoTo 0
.Value = .Value
End With
End With
End With
End Sub
If my explanation was not clear, This is a sample and the output I am trying to create
Thank you all so much in advance for all your help!
You may try something like this...
Sub FillBlanks()
Dim r As Long, lr As Long, lc As Long
Dim cell As Range, FirstCell As Range, LastCell As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(2, Columns.Count).End(xlToLeft).Column
For r = 3 To lr
Set FirstCell = Range(Cells(r, 1), Cells(r, lc)).Find(what:="*", after:=Cells(r, 1))
If Not FirstCell Is Nothing And FirstCell.Column > 1 Then
Set LastCell = Cells(r, Columns.Count).End(xlToLeft)
Range(FirstCell, LastCell).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=RC[-1]"
Range(FirstCell, LastCell).Value = Range(FirstCell, LastCell).Value
End If
Next r
End Sub
And here is yet another solution (just to give you some variety):
Option Explicit
Sub fillInTheBlanks()
Dim lngRow As Long
Dim ws As Worksheet
Dim lngColumn As Long
Dim bolStart As Boolean
Dim lngLastColumn As Long
Dim dblTempValue As Double
Dim arrSheetCopy As Variant
Set ws = ThisWorkbook.Worksheets("Sheet1")
arrSheetCopy = ws.Range(ws.Cells(3, 1), ws.Cells(ws.Cells(ws.Rows.Count, "A").End(xlUp).Row, ws.UsedRange.Columns.Count)).Value2
For lngRow = LBound(arrSheetCopy, 1) To UBound(arrSheetCopy, 1)
bolStart = False
lngLastColumn = 0
For lngColumn = LBound(arrSheetCopy, 2) To UBound(arrSheetCopy, 2)
If Not arrSheetCopy(lngRow, lngColumn) = vbEmpty Then lngLastColumn = lngColumn
Next lngColumn
For lngColumn = LBound(arrSheetCopy, 2) To lngLastColumn
If arrSheetCopy(lngRow, lngColumn) = vbEmpty And bolStart Then
arrSheetCopy(lngRow, lngColumn) = dblTempValue
Else
If Not arrSheetCopy(lngRow, lngColumn) = vbEmpty And IsNumeric(arrSheetCopy(lngRow, lngColumn)) Then
bolStart = True
dblTempValue = CDbl(arrSheetCopy(lngRow, lngColumn))
End If
End If
Next lngColumn
Next lngRow
ws.Range("A3").Resize(UBound(arrSheetCopy, 1), UBound(arrSheetCopy, 2)).Value2 = arrSheetCopy
End Sub
This one is probably the fastest solution (even though it seems a bit bulky with much more lines of code when compared to the other solutions). That's due to the fact that this solution is doing most of the work in memory and not on the sheet. The entire sheet is loaded into a variable and then the work is done on the variable before the result (the variable) is written back to the sheet. So, if you have a speed problem then you might want to consider using this solution.
Here is one possible that meets your sample data's expectations.
Sub wqewqwew()
Dim i As Long, fc As Variant, lc As Long
'necessary if you do not want to confirm numbers and blanks in any row
On Error Resume Next
With ThisWorkbook.Worksheets("Sheet6")
For i = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
If CBool(Application.Count(Rows(i))) Then
fc = Intersect(.Rows(i), .UsedRange).Offset(0, 1).SpecialCells(xlCellTypeConstants, xlNumbers).Cells(1).Column
If Not IsError(fc) Then
lc = Application.Match(9 ^ 99, .Rows(i))
On Error Resume Next
With .Range(.Cells(i, fc), .Cells(i, lc))
.SpecialCells(xlCellTypeBlanks).Cells.FormulaR1C1 = "=RC[-1]"
.Value = .Value2
End With
End If
End If
Next i
End With
End Sub
Just another solution:
The following code can help is there you need to auto-fill the previous values between 1st and last cells depending on value of 1st cell as mentioned in question Excel - VBA fill in cells between 1st and Last value
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
For i = 2 To Target.Column
If Cells(Target.Row, i) = "" Then
If Cells(Target.Row, i - 1) <> "" Then
Range(Cells(Target.Row, i), Cells(Target.Row, i)).Value = Range(Cells(Target.Row, i - 1), Cells(Target.Row, i - 1)).Value
End If
End If
Next i
End Sub
This sub is activated by clicking on any cell. Same cell marks the end of the loop i.e. to stop the loop just click the cell till which you want to fill the blank cells.
The point of this code is to take user inputs from a "Remove Flags" tab in which the user puts an item number and what program it belongs to, filters the "Master List" tab by the item number and the program, then match the name of the flag to the column and delete the flag. However the offset is not working. It is instead deleting the header. When I step through it everything works fine until the line I marked with '*******.
I am fairly new to VBA and am self taught so any and all help is greatly appreciated. Thank you very much for your time.
EDIT: Removed "On Error Resume Next" and fixed some spelling errors. Current issue is with rng not having >1 rows when it is filtered and definitely has two rows (one row is the header, one row is the returned data.)
Sub RemoveFlag()
Dim cel As Range
Dim rg As Range
Dim d As Double
Dim i As Integer
Dim m As Integer
Dim n As Integer
Dim rng As Range
Dim wsMaster As Worksheet
Dim wsFlag As Worksheet
Set wsMaster = Worksheets("Master List")
Set wsFlag = Worksheets("Remove Flags")
i = 6
'If there is no data. Do nothing.
If wsFlag.Range("C6") = "" Then
wsFlag.Activate
Else
Application.ScreenUpdating = False
'Add Leading zeroes
wsFlag.Activate
Set rg = Range("C6")
Set rg = Range(rg, rg.Worksheet.Cells(Rows.Count, rg.Column).End(xlUp))
rg.NumberFormat = "#"
For Each cel In rg.Cells
If IsNumeric(cel.Value) Then
d = Val(cel.Value)
cel.Value = Format(d, "000000000000000000") 'Eighteen digit number
End If
Next
'Clear all the filters on the Master List tab.
wsMaster.Activate
If wsMaster.AutoFilterMode = True Then
wsMaster.AutoFilterMode = False
End If
'Loop through all lines of data
Do While wsFlag.Cells(i, 3).Value <> ""
'Filter by the SKU number
wsMaster.Range("A1").AutoFilter Field:=4, Criteria1:=wsFlag.Cells(i, 3).Value
'Filter by the Program
wsMaster.Range("A1").AutoFilter Field:=2, Criteria1:=wsFlag.Cells(i, 2).Value
'If the filter is not empty find the column of the flag
Set rng = wsMaster.UsedRange.SpecialCells(xlCellTypeVisible)
If (rng.Rows.Count > 1) Then
wsMaster.Range("A1:Z1").Find(wsFlag.Cells(i, 4), LookIn:=xlValues).Activate
n = ActiveCell.Column
Sheets("Master List").Range.Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
m = ActiveCell.Row
Cells(m, n) = ""
wsFlag.Activate
wsFlag.Range(Cells(i, 2), Cells(i, 4)).ClearContents
Else
wsFlag.Activate
wsFlag.Range(Cells(i, 2), Cells(i, 4)).Copy
wsFlag.Range("F4").End(xlDown).Offset(1, 0).Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues
wsFlag.Range(Cells(i, 2), Cells(i, 4)).ClearContents
End If
wsMaster.Activate
wsMaster.AutoFilterMode = False
i = i + 1
Loop
'Make sure the entire Master List tab is not highlighted and pull the 'highlighted cell' to A1 in both tabs.
wsMaster.Activate
wsMaster.Range("A1").Activate
wsFlag.Activate
Range("A1").Activate
'Unfreeze the screen
Application.ScreenUpdating = True
End If
End Sub
As #Zerk suggested, first set two Worksheet variables at top of code:
Dim wsMaster As Worksheet
Dim wsRemoveFlags As Worksheet
Set wsMaster = Worksheets("Master List")
Set wsRemoveFlags = Worksheets("Remove Flags")
Then replace all other instances of Worksheets("Master List") with wsMaster and Worksheets("Remove Flags") with wsRemoveFlags.
Sometimes it's easier to just loop through your rows and columns. Something like the following:
Replace everything between:
Do While wsFlag.Cells(i, 3).Value <> ""
...
Loop
with:
Do While wsFlag.Cells(i, 3).Value <> ""
Dim r As Long ' Rows
Dim c As Long ' Columns
Dim lastRow As Long
Dim found As Boolean
lastRow = wsMaster.Cells.SpecialCells(xlLastCell).Row
found = False
For r = 2 To lastRow ' Skipping Header Row
' Find Matching Program/SKU
If wsMaster.Cells(r, 2).Value = wsFlag.Cells(i, 2).Value _
And wsMaster.Cells(r, 3) = wsFlag.Cells(i, 3).Value Then
' Find Flag in Row
For c = 1 To 26 ' Columns A to Z
If wsMaster.Cells(r, c) = wsFlag.Cells(i, 4) Then
' Found Flag
wsMaster.Cells(r, c) = ""
found = True
Exit For ' if flag can be in more than one column, remove this.
End If
Next 'c
End If
Next 'r
If Not found Then
' Here is where you need to put code if Flag wsFlag.Cells(i, 4) not found.
End If
Loop