I am trying to write code that would shift the range of cells from the current cell till the last cell that has data in the row one cell to the right if the relative cell that contains the weekday has the values fri or sat.
My code is below, however when it runs, Excel would not respond and restarts by itself. I don't really know where the problem is.
Note: i is the row index, j is the column index
Sub shiftcell()
Dim i As Integer
Dim j As Integer
Dim lcol As Integer
Dim rng As Range
For i = 8 To 18
For j = 6 To 70
If (Sheets("master").Cells(6, j).Value = "Fri" Or
Sheets("master").Cells(6, j).Value = "Sat") Then
lcol = Sheets("MASTER").Cells(i, Columns.COUNT).End(xlToLeft).Column
Set rng = Range(Cells(i, j), Cells(i, lcol))
rng.Cut rng.Cells(i).Offset(0, 1)
End If
Next j
Next i
End Sub
This should work for you (you can omit the second loop over the rows by selecting the whole range at once, as long as the rows have the same length. Otherwise bring back the row loop but inside the if environement):
Sub shiftcell()
Dim j, lcol As Long
Dim rngFrom, rangeTo As Range
For j = 6 To 70
If ((Sheets("master").Cells(6, j).Value = "Fri") Or (Sheets("master").Cells(6, j).Value = "Sat")) Then
lcol = Sheets("master").Cells(8, Columns.Count).End(xlToLeft).Column
If (lcol >= j) Then
Set rngFrom = Range(Cells(8, j), Cells(18, lcol))
Set rngTo = Range(Cells(8, j + 1), Cells(18, lcol + 1))
rngFrom.Cut rngTo
End if
End If
Next j
End Sub
Related
I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub
Hello I am trying to copy a range into a single column. The range is a mix of blank cells and cells with values.I only want to copy and paste the cells with values and I would it to find the first blank cell and want it to walk itself down the column from there.
The code I have right now (besides taking forever) pastes in the first row.
Dim i As Integer
i = 1
ThisWorkbook.Worksheets("amount date").Select
For Row = 51 To 100
For col = 2 To 1000
If Cells(Row, col).Value <> "" Then
Cells(Row, col).Copy
Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues
End If
Next
Next
Do While Worksheets("sheet 2").Range("G" & i).Value <> ""
i = i + 1
Loop
End Sub
This will work:
Sub qwerty()
Dim i As Long, r As Long, c As Long
i = 1
ThisWorkbook.Worksheets("amount date").Select
For r = 51 To 100
For c = 2 To 1000
If Cells(r, c).Value <> "" Then
Cells(r, c).Copy
Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues
i = i + 1
End If
Next
Next
End Sub
Perhaps this will be a little faster (even though it seems to have been slow arriving).
Sub CopyRangeToSingleColumn()
' 20 Oct 2017
Dim LastRow As Long
Dim LastClm As Long
Dim Rng As Range, Cell As Range
Dim CellVal As Variant
Dim Spike(), i As Long
With ThisWorkbook.Worksheets("amount date")
With .UsedRange.Cells(.UsedRange.Cells.Count)
LastRow = Application.Max(Application.Min(.Row, 100), 51)
LastClm = .Column
End With
Set Rng = .Range(.Cells(51, "A"), .Cells(LastRow, LastClm))
End With
ReDim Spike(Rng.Cells.Count)
For Each Cell In Rng
CellVal = Trim(Cell.Value) ' try to access the sheet less often
If CellVal <> "" Then
Spike(i) = CellVal
i = i + 1
End If
Next Cell
If i Then
ReDim Preserve Spike(i)
With Worksheets("sheet 2")
LastRow = Application.Max(.Cells(.Rows.Count, "G").End(xlUp).Row, 2)
.Cells(LastRow, "G").Resize(UBound(Spike)).Value = Application.Transpose(Spike)
End With
End If
End Sub
The above code was modified to append the result to column G instead of over-writing existing cell values.
Do you need copy the whole row into one cell, row by row? For each loop shall be faster. I guess, this should work
Sub RowToCell()
Dim rng As Range
Dim rRow As Range
Dim rRowNB As Range
Dim cl As Range
Dim sVal As String
Set rng = Worksheets("Sheet3").Range("$B$51:$ALN$100") 'check this range
For Each rRow In rng.Rows
On Error Resume Next
Set rRowNB = rRow.SpecialCells(xlCellTypeConstants)
Set rRowNB = Union(rRow.SpecialCells(xlCellTypeFormulas), rRow)
On Error GoTo 0
For Each cl In rRowNB.Cells
sVal = sVal & cl.Value
Next cl
Worksheets("sheet4").Range("G" & rRow.Row - 50).Value = sVal
sVal = ""
Next rRow
End Sub
its quick for this range.
I'm trying to add the cells in the rows ranging 6 to 80, columns ranging 4 to 23 from sheet 7 to sheets.count and dump the added value in sheet 5. This is what I did so far with the help of another SO member. I can't figure out the reason for error 91.
Error is on this line: ar(i, j) = ar(i, j) + ws.Cells(i, j)
Sub Sample()
Dim ws As Worksheet, wsSummation As Worksheet
Dim startRow As Long, StartCol As Long
Dim endRow As Long, endCol As Long
Dim i As Long, j As Long
Dim ar(6 To 80, 4 To 23) As Variant
Dim myTotal As Variant
Dim x As Long
x = 7
'~~> Start row and start column
startRow = 6: StartCol = 4
endRow = 6: endCol = 4
'Set myTotal = Sheets.Count 'total sheet count
'~~> Summary sheet
'Set wsSummation = Sheet5
'~~> Looping through each worksheet from Summation to end
For x = 7 To ThisWorkbook.Worksheets.Count
'~~> Check if it is not the summary sheet
'If ws.Name <> wsSummation.Name Then
'~~> Loop through the row and columns and
'~~> Store it in an array
For i = startRow To endRow
For j = StartCol To endCol
ar(i, j) = ar(i, j) + ws.Cells(i, j)
Next j
Next i
'End If
Next x
'~~> Write array to summary sheet
wsSummation.Range("D6").Resize(UBound(ar), UBound(ar)).Value = ar
End Sub
I'll write a few lines to help you understand what #Mat's Mug trying to explain.
You are looping through the Workbook's worksheets, but you don't set your ws object to the worksheet you are trying to loop. So, afterwards, you are reaching this line ar(i, j) = ar(i, j) + ws.Cells(i, j) you are getting an error, since ws was never set-up properly.
Try the Code loop below :
'~~> Looping through each worksheet from Summation to end
For x = 7 To ThisWorkbook.Worksheets.Count
' ==== YOU NEED to SET the WORKSHEET OBJECT FIRST, BEFORE YOU USE IT
'~~> Check if it is not the summary sheet
Set ws = ThisWorkbook.Worksheets(x)
With ws ' have a with statement to simplify your nested code
'If ws.Name <> wsSummation.Name Then
'~~> Loop through the row and columns and
'~~> Store it in an array
For i = startRow To endRow
For j = StartCol To endCol
ar(i, j) = ar(i, j) + .Cells(i, j)
Next j
Next i
'End If
End With
Next x
I'm trying to remove the blank records from a combobox with two lists.
This is my code:
Private Sub UserForm_Initialize()
Dim N As Range
Dim LastRow As Integer
Dim ws As Worksheet
PREST.ColumnCount = 2
Set ws = Worksheets("L_Location")
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim i, j As Integer
Dim location(2 To 100, 1 To 2) As String
For j = 1 To 2
For i = 2 To LastRow
If ws.Cells(i, j).Value <> vbNullString Then
location(i, j) = ws.Cells(i, j).Value
End If
Next i
Next j
PREST.List = location
End Sub
I don't know what I'm doing wrong.
You are having blanks because your 2D array is already sized with 100 rows. A simple workaround would be to first count the non-empty rows, then dimension the Array accordingly.
Dim location() As String
Dim count As Long
count = Range("A2:A" & LastRow).SpecialCells(xlCellTypeConstants).Cells.count
ReDim location(1 To count, 1 To 2)
'then continue from here to fill the array
This code will fill the combobox with your range value then will delete any empty item:
Private Sub UserForm_Initialize()
Dim LastRow As Long
Dim ws As Worksheet
PREST.ColumnCount = 2
Set ws = Worksheets("L_Location")
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim i As Long ', j As Integer
PREST.List = ws.Range("a1:b" & LastRow).Value
For i = PREST.ListCount - 1 To 0 Step -1
If PREST.List(i) = "" Then PREST.RemoveItem i
Next
End Sub
I tried this :
Dim location() As String
ReDim location(LastRow - 2, 1)
For j = 0 To 1
For i = 0 To LastRow - 2
If ws.Cells(i + 2, j + 1).Value <> vbNullString And ws.Cells(i + 2, j + 1).Value <> "" Then
location(i, j) = ws.Cells(i + 2, j + 1).Value
End If
Next i
Next j
PREST.List = location
which seems to work but i guess its gonna give me an error if the list is empty (lastrow = 1)
Since you say that any two cells on the same row are both either blank or with values, then you could go like follows:
Dim cell As Range
Dim i As Long, j As Long
PREST.ColumnCount = 2
With Worksheets("L_Location") '<--| reference your worksheet
With .Range("A2", .Cells(.Rows.Count,1).End(xlUp)).SpecialCells(xlCellTypeConstants) '<--| reference its column A not empty cells from row 1 down to last not empty one
Dim location(1 To .Count, 1 To 2) As String '<--| size your array rows number to that of referenced cells
For Each cell In .Cells '<--| loop through referenced cells
i = i + 1 '<--| update array row index
For j = 1 To 2 '<--| loop through array columns
location(i, j) = cell.Offset(j -1).Value '<--| fill array
Next j
Next cell
End With
End With
PREST.List = location
I have a piece of VB code in excel to hide columns with less than 2 data entries (header as a minimum) and I need to know how to use this to hide columns whilst ignoring information in filtered out rows:
Sub HideCols()
Dim LC As Integer, j As Integer
Dim cl As Range, rng As Range
Set rng = Range("Table1").SpecialCells(xlCellTypeVisible)
LC = Cells(3, Columns.Count).End(xlToLeft).Column
For j = 3 To LC
Columns(j).Hidden = WorksheetFunction.CountA(Columns(j)) < 2
Next j
Application.ScreenUpdating = True
End Sub
This is what I have, a lot of it makes no sense and needs tidying up but that's only as I've been trying to find my own way to no avail.
Thanks!
I'd go like follows
Option Explicit
Sub HideCols()
Dim cols As Range
Dim iCol As Long
With Range("Table1")
Set cols = .Resize(1, 1).Offset(, .Columns.Count + 1)
For iCol = 1 To .Columns.Count
If Application.WorksheetFunction.Subtotal(103, .Columns(iCol).SpecialCells(xlCellTypeVisible)) < 2 Then Set cols = Union(cols, .Cells(1, iCol))
Next iCol
Set cols = Intersect(.Columns, cols)
If Not cols Is Nothing Then cols.EntireColumn.Hidden = True
End With
End Sub
as a side note, if filtering is done out of Autofilter() method then also header rows are not filtered out. in this case you may want to change the right term of If check to < 3
Check if it's hidden first
Sub HideCols()
Dim LC As Integer, j As Integer
Dim LR As Integer, curCnt as Integer
Dim cl As Range, rng As Range
Dim Data As Variant
Set rng = Range("Table1").SpecialCells(xlCellTypeVisible)
LC = Cells(3, Columns.Count).End(xlToLeft).Column
For j = 3 To LC
LR = Cells(Rows.Count, j).End(xlUp).Row
curCnt = 0
' its faster to iterate a variant array than it is Cells
Data = Range( Cells(1, 1), Cells(LR, LC) )
for k = 1 to LR
if Rows(k).Hidden = False and Data(k, j) <> "" Then _
curCnt = curCnt + 1
next k
Columns(j).Hidden = curCnt < 2
Next j
Application.ScreenUpdating = True
End Sub