Sheet1 Have 90 columns and 288 rows. Some cells of each row have value and some are blank (containing formula). I want to rearrange each row data in Sheet2 as value contain cells come to left and blank goes to right. I don’t want to remove the blank cells so, if a row doesn’t have any data will not got removed. Row order is very important in my case.
Sheet1 got updated each 5 minutes, if there is any possibility to update Sheet2 each 5 minute that will be really great.
Example:
Sheet1
Sheet1
Sheet2Sheet2
NB: My VBA or Macro knowledge is very basic. If I’m not asking too much, explanation to apply the solutions will be great.
Using office 365 latest version
If you are having a hard time finding a place to start, you could try this Worksheet_Change event macro for Sheet1.
Option Explicit
Private dALL As Double
Private Sub Worksheet_Change(ByVal Target As Range)
If Application.Sum(Target.Parent.UsedRange.Cells) <> dALL Then
dALL = Application.Sum(Target.Parent.UsedRange.Cells)
On Error GoTo bm_Safe_Exit
'suspend events so nothing on Sheet2 gets triggered
Application.EnableEvents = False
Dim a As Long, i As Long, j As Long, aVALs As Variant
aVALs = Target.Parent.UsedRange.Cells.Value2
For i = LBound(aVALs, 1) To UBound(aVALs, 1)
For j = LBound(aVALs, 2) To UBound(aVALs, 2) - 1
If Not CBool(Len(aVALs(i, j))) Then
For a = j + 1 To UBound(aVALs, 2)
If CBool(Len(aVALs(i, a))) Then
aVALs(i, j) = aVALs(i, a)
aVALs(i, a) = vbNullString
Exit For
End If
Next a
End If
Next j
Next i
With ThisWorkbook.Worksheets("Sheet2")
.UsedRange.Clear
.Cells(1, 1).Resize(UBound(aVALs, 1), UBound(aVALs, 2)) = aVALs
End With
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
Related
I have what I thought would be a simple script, but I have some some strange results.
Goal: Identify specific IDs in a SOURCE sheet using a list of IDs on a Translator Sheet. When found, copy the entire row to and OUTPUT sheet.
The output has strange results that I can't figure out.
Returns all results instead of the limited list. AND results are in weird groupings. (First result is on row 21 and only has 9 rows of data, the next group has 90 rows of data, starting on row 210, then blank rows, then 900 rows of data, etc.
Results do not start in row 2.
Full code is below attempts:
Attempts:
I first searched the SOURCE sheet based on one ID that was hard coded as a simple test and it worked. but when I changed the code to search a range (z21:z), two things happened: 1, it returns everything in the Source file in multiples of 9 as stated above, AND as you can imagine, the time to complete skyrocketed from seconds to minutes. I think I missed a add'l section of code to identify the range??
Old Code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("D62D627EB404207DE053D71C880A3E05") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
New code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I)** Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
1a. I believe one issue is that the Translator list has duplicates. Second, it is searching the entire column Z. Second issue may be that The list in Translator is generated via a formula in column Z, thus if the formula is false, it will insert a "" into the cell. I seek the code to NOT paste those rows where the cell content is either a "" or is a true blank cell. Reason: The "" will cause issues when we try to load the Output file into a downstream system because it is not a true blank cell.
Results in wrong location: When the script is complete, my first result does not start on Row 2 as expected. I thought the clear contents would fix this, but maybe a different clear function is required? or the clear function is in the wrong place? Below screenshot shows how it should show up. It is in the same columns but doesn't start until row 21.
enter image description here
Slow code: I have a command that copies and pastes of the first row from SOURCE to OUTPUT. My code is cumbersome. There has to be an easier way. I am doing this copy and paste just in case the source file adds new columns in the future.
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Thank you for all your help.
Option Explicit
Sub MoveRowBasedOnCellValuefromlist()
'Updated by xxx 2023.01.18
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("SOURCE").UsedRange.Rows.Count
J = Worksheets("Output").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Output").UsedRange) = 0 Then J = 0
End If
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Set xRg = Worksheets("SOURCE").Range("B2:B" & I)
On Error Resume Next
Application.ScreenUpdating = False
'NOTE - There are duplicates in the Translator list. I only want it to paste the first instance.
'Otherwise, I need to create an =Unique() formula and that seems like unnecessary work.
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I) Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Try this out - using Match as a fast way to check if a value is contained in your lookup list.
Sub MoveRowBasedOnCellValuefromlist()
Dim c As Range, wsSrc As Worksheet, wsOut As Worksheet, wb As Workbook
Dim cDest As Range, wsTrans As Worksheet, rngList As Range
Set wb = ThisWorkbook 'for example
Set wsSrc = wb.Worksheets("SOURCE")
Set wsOut = wb.Worksheets("Output")
Set wsTrans = wb.Worksheets("Translator")
Set rngList = wsTrans.Range("Z21:Z" & wsTrans.Cells(Rows.Count, "Z").End(xlUp).Row)
ClearSheet wsOut
wsSrc.Rows(1).Copy wsOut.Rows(1)
Set cDest = wsOut.Range("A2") 'first paste destination
Application.ScreenUpdating = False
For Each c In wsSrc.Range("B2:B" & wsSrc.Cells(Rows.Count, "B").End(xlUp).Row).Cells
If Not IsError(Application.Match(c.Value, rngList, 0)) Then 'any match in lookup list?
c.EntireRow.Copy cDest
Set cDest = cDest.Offset(1) 'next paste row
End If
Next c
Application.ScreenUpdating = True
End Sub
'clear a worksheet
Sub ClearSheet(ws As Worksheet)
With ws.Cells
.ClearContents
.ClearFormats
End With
End Sub
I have a worksheet with 3 rows and 7 columns (A1:G3).
A and B columns have 6 checkboxes (A1:B3). Boxes in columns A & B are linked to columns C & D respectively. Cells in columns E & F are just replicating columns C & D respectively (live E1 cell is =C1 and F3 cell is =D3).
I want to put a timestamp in cell G for each row when a checkbox is ticked or unticked by using Worksheet_Calculate event in VBA for that sheet.
My code works when used for just 1 row.
Private Sub Worksheet_calculate()
Dim cbX1 As Range
Set cbX1 = Range("A1:F1")
If Not Intersect(cbX1, Range("A1:F1")) Is Nothing Then
Range("G1").Value = Now()
End If
End Sub
I want to combine the code for 3 rows.
Here are 2 variations:
1st one:
Private Sub Worksheet_calculate()
Dim cbX1 As Range
Dim cbX2 As Range
Dim cbX3 As Range
Set cbX1 = Range("A1:F1")
Set cbX2 = Range("A2:F2")
Set cbX3 = Range("A3:F2")
If Not Intersect(cbX1, Range("A1:F1")) Is Nothing Then
Range("G1").Value = Now()
ElseIf Intersect(cbX2, Range("A2:F2")) Is Nothing Then
Range("G2").Value = Now()
ElseIf Intersect(cbX3, Range("A3:F3")) Is Nothing Then
Range("G3").Value = Now()
End If
End Sub
When I combine them with ElseIf like in the code above, a timestamp gets put in only G1, no matter if I tick B1 or C2.
2nd one:
Private Sub Worksheet_calculate()
Dim cbX1 As Range
Dim cbX2 As Range
Dim cbX3 As Range
Set cbX1 = Range("A1:F1")
If Not Intersect(cbX1, Range("A1:F1")) Is Nothing Then
Range("G1").Value = Now()
End If
Set cbX2 = Range("A2:F2")
If Not Intersect(cbX2, Range("A2:F2")) Is Nothing Then
Range("G2").Value = Now()
End If
Set cbX3 = Range("A3:F2")
If Not Intersect(cbX3, Range("A3:F3")) Is Nothing Then
Range("G3").Value = Now()
End If
End Sub
When I combine them by ending each one with End If and start a new If, timestamp gets put in all of the G1, G2 and G3 cells, even if I tick just one of the boxes.
You seem to be confusing Worksheet_Calculate with Worksheet_Change and using Intersect as if one of the arguments was Target (which Worksheet_Calculate does not have).
Intersect(cbX1, Range("A1:F1")) is always not nothing because you are comparing six apples to the same six apples. You might as well ask 'Is 1,2,3,4,5,6 the same as 1,2,3,4,5,6?'.
You need a method of recording the values of your range of formulas from one calculation cycle to the next. Some use a public variable declared outside the Worksheet_calculate sub procedure; personally I prefer a Static variant array declared within the Worksheet_calculate sub.
The problem with these is initial values but this can be accomplished since workbooks undergo a calculation cycle when opened. However, it is not going to register Now in column G the first time you run through a calculation cycle; you already have the workbook open when you paste in the code and it needs one calculation cycle to 'seed' the array containing the previous calculation cycle's values.
Option Explicit
Private Sub Worksheet_Calculate()
Static vals As Variant
If IsEmpty(vals) Then 'could also be IsArray(vals)
vals = Range(Cells(1, "A"), Cells(3, "F")).Value2
Else
Dim i As Long, j As Long
With Range(Cells(1, "A"), Cells(3, "F"))
For i = LBound(vals, 1) To UBound(vals, 1)
For j = LBound(vals, 2) To UBound(vals, 2)
If .Cells(i, j).Value2 <> vals(i, j) Then
Application.EnableEvents = False
.Cells(i, "G") = Now
Application.EnableEvents = True
vals(i, j) = .Cells(i, j).Value2
End If
Next j
Next i
End With
End If
End Sub
I´m trying to create an Excelsheet that runs multiple VBA scripts after writing anything in A Column.
One part I would like some help with is that the character 2,3 and 4 written in A column (any row) should be written i D column same row.
I also would like to remove any information i D Column if I remove the text from A Column.
I have manage to create a script that calls modules after writing information i a cell in A Column
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Me.Range("A:A")) Is Nothing Then Exit Sub
Application.EnableEvents = False 'to prevent endless loop
On Error GoTo Finalize 'to re-enable the events
Call Modul1.Module
Finalize:
Application.EnableEvents = True
End Sub
Any help would be much appriciated.
This is what I have for now.
It doesn´t work to clear value on all rows only some of them?!
Sub Lokation()
Dim n As Long, i As Long, j As Long
n = Cells(Rows.Count, "A").End(xlUp).Row
j = 2
For i = 2 To n
If Cells(i, "A").Value = vbNullString Then
Cells(j, "D").Value = ("")
Else
Cells(j, "D").Value = Mid(Cells(j, "A").Value, 2, 3)
End If
j = j + 1
Next i
End Sub
You can wrap this whole piece up in just the Worksheet_Change event if you use the following:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim columnAcell As Range
If Intersect(Target, Me.Range("A:A")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each columnAcell In Target.Cells
columnAcell.Offset(0, 3) = Mid(columnAcell, 2, 3)
Next
Application.EnableEvents = True
End Sub
Instead of specifically writing to column D, I've used a cell offset of 3 columns from Target. As this code only looks at column A currently, it will always offset to column D.
Things to watch out for though -
Altering cell(A1) which contains the header would result in cell(D1) being altered. You can prevent this by changing the Intersect range from A:A to something like A2:Axxxx
Deleting the entirety of column A would result in the loop running for a very long time, not to mention causing column D to move to column C. You may want to prevent users from being able to do this.
I have tried my best to search for the answer but can't get what I'm looking for. I'm very new to VBA so may be going wrong in several places here . . .
I'm creating a data formatter that processes data with a different numbers of records (rows) each time it is used. Data will be on non-active sheet. First row has headings. I've successfully used similar code to the code below to identify rows with certain data on it and clear the contents of other cells on that row.
The reason I refer to column E is because it is the only column that has data in every record. I then have to find the rows that have a value in column BU, then multiply that value by 20 and insert the result in column BX of the same row.
I keep getting Run-time Error 13 but don't understand as it's simply a number with 2 decimal places in cell BU, and currently there is nothing in BX.
Sub CalcTotalLTA()
Dim i As Variant
'counts the no. of rows in E and loops through all
For i = 1 To Sheets("Input").Range("E2", Sheets("Input").Range("E2").End(xlDown)).Rows.Count
'Identifies rows where columns BU has a value
If Sheets("Input").Cells(i, 73).Value <> "" Then
'calculate Total LTA
Sheets("Input").Cells(i, 76).Value = Sheets("Input").Cells(i, 73).Value * 20
End If
Next i
End Sub
You're most likely having an issue because Application.Sheets holds both sheet types, which are Charts and Worksheets. Application.Sheets does not have a .Range() property.
Replace all instances of Sheets() with Worksheets().
Worksheets("Input").Cells(i, 76).Value = Worksheets("Input").Cells(i, 73).Value * 20
Even better:
Dim ws as Worksheet
Set ws = Worksheets("Input")
..
ws.Cells(i,76).Value = ws.Cells(i,73).Value * 20
Exclude Header Row From Range
Public Function rngExcludeHeaders(rng As Range) As Range
Set rng = rng.Offset(1, 0).Resize(rng.rows.count - 1, rng.Columns.count)
Set rngExcludeHeaders = rng
End Function
usage:
Dim MyRange as Range
Set MyRange = rngExcludeHeaders(ws.UsedRange)
Thanks to input from #Adam Vincent and #Vityata, and some other research (the reason why I'm solving this myself, hope that's not bad etiquette) I've found the solution. Starting the index 'i' at 2 and adding 1 at the end avoids the header row text and includes the last row too:
Option Explicit
Sub CalcTotalLTA()
Dim i As Variant
Dim ws As Worksheet
Set ws = Worksheets("Input")
'counts the no. of rows in E and loops through all
For i = 2 To ws.Range("E2", ws.Range("E2").End(xlDown)).Rows.Count + 1
'Identifies rows where columns BU has a value
If ws.Cells(i, 73).Value <> "" Then
'calculate Total LTA
ws.Cells(i, 76).NumberFormat = "0.00"
ws.Cells(i, 76).Value = ws.Cells(i, 73).Value * 20
End If
Next i
End Sub
Try it like this:
Option Explicit
Sub CalcTotalLTA()
Dim i As Long
With Worksheets("Input")
For i = 1 To .Range("E2", .Range("E2").End(xlDown)).Row
If .Cells(i, 3) <> "" Then
.Cells(i, 6) = .Cells(i, 3) * 20
End If
Next i
End With
End Sub
This is what I have changed:
Adding Option Explicit on top
I have used With Worksheets("Input") to make your code more understandable.
Furthermore, I suppose you do not need Rows.Count but .Row
I have changed 76 and 73 to 3 and 6 to avoid some scrolling to the right, thus be careful when you use it over your workbook.
Removed .Value as far as it is the default one.
I don't really have much of a background in VBA, but I'm trying to create a macro where, on the push of a button all rows that do not have a check mark in them in a certain range are deleted. I browsed some forums, and learned about a "marlett" check, where the character "a" in that font is displayed as a check mark. Here is the code I have to generate the "marlett check" automatically when clicking a cell in the A column in the appropriate range:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("A10:A111")) Is Nothing Then
Target.Font.Name = "Marlett"
If Target = vbNullString Then
Target = "a"
Else
Target = vbNullString
End If
End If
End Sub
I then have another macro (assigned to a button) that actually deletes the rows without a check mark in the "A" column when the button is pressed:
Sub delete_rows()
Dim c As Range
On Error Resume Next
For Each c in Range("A10:A111")
If c.Value <> "a" Then
c.EntireRow.Delete
End If
Next c
End Sub
Everything works, but the only problem is that I have to press the button multiple times before all of the unchecked rows are deleted!! It seems like my loop is not working properly -- can anyone please help??
Thanks!
I think this may be due to how you're deleting the rows, you might be skipping a row after every delete.
You might want to change your for-each for a regular for loop. so you can control the index you'r working on. see this answer or the other answers to the question to see how to do it.
Heres a modified version that should suit your (possible) problem.
Sub Main()
Dim Row As Long
Dim Sheet As Worksheet
Row = 10
Set Sheet = Worksheets("Sheet1")
Application.ScreenUpdating = False
Do
If Sheet.Cells(Row, 1).Value = "a" Then
'Sheet.Rows(Row).Delete xlShiftUp
Row = Row + 1
Else
'Row = Row + 1
Sheet.Rows(Row).Delete xlShiftUp
End If
Loop While Row <= 111
Application.ScreenUpdating = True
End Sub
Update
Try the edit I've made to the if block, bit of a guess. Will look at it when I have excel.
It does go into an infinite loop regardless of the suggested change.
The problem was when it got near the end of your data it continually found empty rows (as theres no more data!) so it kept deleting them.
The code below should work though.
Sub Main()
Dim Row As Long: Row = 10
Dim Count As Long: Count = 0
Dim Sheet As Worksheet
Set Sheet = Worksheets("Sheet1")
Application.ScreenUpdating = False
Do
If Sheet.Cells(Row, 1).Value = "a" Then
Row = Row + 1
Else
Count = Count + 1
Sheet.Rows(Row).Delete xlShiftUp
End If
Loop While Row <= 111 And Row + Count <= 111
Application.ScreenUpdating = True
End Sub