I am trying to write a change log for excel VBA. I want it to iterate through so that the each additional response is populated in the workbook as the additional rows. Please let me know if you have any insight into what is wrong with my code
Dim streply As String
Dim Today As Date
Dim myrange As Range
Dim inglastrow As Long
CurrentDate = Date
With Sheets("Sheet1")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
nextrow = lastrow + 1
MsgBox lastrow
MsgBox nextrow
End With
MsgBox lastrow
streply = InputBox(Prompt:="Please type description of changes", Title:="Change Log", Default:="Brief Desc.")
If streply <> " " Then
Range("A" & nextrow).Value = Application.UserName
Range("B" & nextrow).Value = streply
Range("C" & nextrow).Value = ActiveWorkbook.Name
Range("D" & nextrow).Value = Date
End If
Set lastrow = Nothing
Set nextrow = Nothing
End Sub
EDIT: silly mistake on my part, fixed now
Instead of:
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
Try:
lastrow = .UsedRange.Rows.Count
Related
I need help to create one VBA for below issue -
column C should be updated based on column A and B values.
in below example if column A=Unit1 and column B=IND then Person 1 and so on.. it should loop till end.
Thank you in adv. please refer picture for sample data
enter image description here
Here you go. Just change the sheet name since I don't know what you're working with.
Sub AddPerson()
Dim i As Long, ws As Worksheet, lRow As Long
Set ws = Sheets("Sheet1") 'Change to your sheet name
lRow = ws.Range("A" & Rows.Count).End(xlUp).Row
With ws
.Range("C2:C" & lRow + 1).ClearContents
For i = 2 To lRow
If .Range("B" & i) = "IND" Then
.Range("C" & i) = "Person1"
ElseIf .Range("A" & i) = "Unit5" And .Range("B" & i) = "OTR" Then
.Range("C" & i) = "Person3"
Else
.Range("C" & i) = "Person2"
End If
Next i
End With
End Sub
I have the code below to hide all blank cells on my sheet. How do I set the hide range to 100 so after cell 100 if the remaining ones are blank it doesn't hide them. Only cells within the 1-100 limit get hidden if blank.
Sub HideRow()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Projects Dashboard")
Dim LRowC, LRowD, LRowF, LRowH, LRow As Long
LRowC = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
LRowD = ws.Range("D" & ws.Rows.Count).End(xlUp).Row
LRowF = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
LRowH = ws.Range("H" & ws.Rows.Count).End(xlUp).Row
LRow = Application.WorksheetFunction.Max(LRowC, LRowD, LRowF, LRowH)
Dim I As Long
Application.ScreenUpdating = False
ws.Rows.Hidden = False
For I = LRow To 7 Step -1
If ws.Range("C" & I).Text = "" And ws.Range("D" & I).Text = "" And ws.Range("F" & I).Text = "" And ws.Range("I" & I).Text = "" Then
ws.Rows(I).EntireRow.Hidden = True
End If
Next I
Application.ScreenUpdating = True
End Sub
If I understand your question and code, it seems that you would want limit your LRow value to be a max of 100.
Should be as simple as adding one line of code:
...
LRow = Application.WorksheetFunction.Max(LRowC, LRowD, LRowF, LRowH)
If LRow > 100 Then LRow = 100
Dim I As Long
...
Looking to up my manual mapping solution of merging worksheets, to a search-map header solution. The basics are this
Dest_Worksheet: This has the only headers that are needed post merge (up to 50 columns)
Source_Worksheet1: This has a list of items with some headers that match Dest_Worksheet (up to 100 columns - different than Source_Worksheet2)
Source_Worksheet2: This has a list of items with some headers that match Dest_Worksheet (up to 100 columns - different than Source_Worksheet1)
Total row count unknown at the time of run. Currently built out a manual mapping (see below).
ASKING: Move beyond manual mapping of each worksheet to a solution which reviews the Dest_Worksheet and references those headers, move through remaining or identified list of Source worksheets and copy all rows with only columns that match Dest_Worksheet.
See sample worksheet for working manual mapping code below
'******Manual Mapping of Source_Data1*******
Sub Source_Data1()
Dim sht As Worksheet
Dim colname As String
Dim Lastrow As Integer, rowcount As Integer
colname = 1
For Each sht In ActiveWorkbook.Worksheets
If sht.Name = "Source_Worksheet1" And sht.Range("A3").Value <> "" Then
Sheets("Source_Worksheet1").Select
Lastrow = Range("A9000").End(xlUp).Row
Sheets("Dest_Worksheet").Select
rowcount = Range("A9000").End(xlUp).Row + 1
sht.Select
Sheets("Dest_Worksheet").Range("A" & rowcount & ":A" & rowcount + Lastrow - 3).Value = sht.Range("A3:A" & Lastrow).Value
Sheets("Dest_Worksheet").Range("B" & rowcount & ":B" & rowcount + Lastrow - 3).Value = sht.Range("B3:B" & Lastrow).Value
Sheets("Dest_Worksheet").Range("C" & rowcount & ":C" & rowcount + Lastrow - 3).Value = sht.Range("C3:C" & Lastrow).Value
Sheets("Dest_Worksheet").Range("D" & rowcount & ":D" & rowcount + Lastrow - 3).Value = sht.Range("D3:D" & Lastrow).Value
End If
Next sht
Worksheets("Dest_Worksheet").Select
End Sub
'******Manual Mapping of Source_Data2*******
Sub Source_Data2()
Dim sht As Worksheet
Dim colname As String
Dim Lastrow As Integer, rowcount As Integer
colname = 1
For Each sht In ActiveWorkbook.Worksheets
If sht.Name = "Source_Worksheet2" And sht.Range("A3").Value <> "" Then
Sheets("Source_Worksheet2").Select
Lastrow = Range("A9000").End(xlUp).Row
Sheets("Dest_Worksheet").Select
rowcount = Range("A9000").End(xlUp).Row + 1
sht.Select
Sheets("Dest_Worksheet").Range("A" & rowcount & ":A" & rowcount + Lastrow - 3).Value = sht.Range("A3:A" & Lastrow).Value
Sheets("Dest_Worksheet").Range("E" & rowcount & ":E" & rowcount + Lastrow - 3).Value = sht.Range("B3:B" & Lastrow).Value
Sheets("Dest_Worksheet").Range("F" & rowcount & ":F" & rowcount + Lastrow - 3).Value = sht.Range("C3:C" & Lastrow).Value
Sheets("Dest_Worksheet").Range("C" & rowcount & ":C" & rowcount + Lastrow - 3).Value = sht.Range("E3:E" & Lastrow).Value
End If
Next sht
Worksheets("Dest_Worksheet").Select
End Sub
After lots of trial and error I got Find() working to return the column letter I'm looking for. Here's the code I ended up using and the associated function call:
Sub LookupText()
Dim DestLetter As String
DestLetter = TextLookup("Search Text")
MsgBox DestLetter
End Sub
'***********
Function TextLookup(TheText As String) As String
Set Cell = Worksheets("Destination_Worksheet").Cells.range("A1:DA1").Find(TheText, , xlValues, xlPart, , , False)
If Not Cell Is Nothing Then
ColLetter = Split(Cell.Address, "$")(1)
TextLookup = ColLetter
End If
End Function
I have a table as shown below.
In column C I would like to Sum values from column A if they have the same index (column B). I would like to put sum result for all the rows if they have same index (as shown in column D).
Unfortunately the range of values with same index is variable and my macro can sum values just with 2 indexes. Can anyone help with it, please? Thanks!
Sub example()
Dim ws As Worksheet
Dim LastRow As Long
Dim n, i As Integer
Set ws = ActiveWorkbook.Sheets("Sheet2")
ws.Select
LastRow = Sheets("Sheet2").Range("A" & Sheets("Sheet2").Rows.Count).End(xlUp).Row
Range("C3:C" & LastRow).Select
Selection.ClearContents
For i = 3 To LastRow
If Range("B" & i + 1) - Range("B" & i) = 0 Then
Range("C" & i) = Range("A" & i + 1) + Range("A" & i)
Else
Range("C" & i) = Range("C" & i - 1)
End If
Next i
End Sub
Here's one way:
Sub example()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = ActiveWorkbook.Sheets("Sheet2")
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
With ws.Range("C3:C" & LastRow)
.ClearContents
.Value = ws.Evaluate("INDEX(SUMIF(B3:B" & LastRow & ",B3:B" & LastRow & ",A3:A" & LastRow & "),)")
End With
End Sub
I have this script that I had help with already, but now comes an issue. I am attempting to paste only the value, not the formula that is inside the cell to another cell.
I thought placing the .Value at the end of formula would tell the script to paste only the value... it seems not to be. Can someone give me a suggestion on how to make this work?
Option Explicit
Sub ONJL()
Dim lastrow As Long
Dim wsPAR As Worksheet 'PAERTO
Dim wsRD As Worksheet 'Raw Data
Dim wsTEM As Worksheet 'Archive
Set wsPAR = Sheets("PAERTO")
Set wsRD = Sheets("Raw Data")
Set wsTEM = Sheets("Template")
With wsRD
Application.ScreenUpdating = False
lastrow = .Range("J" & .Rows.Count).End(xlUp).Row
wsRD.Range("J" & lastrow + 1).Formula = Date
wsRD.Range("B2").Copy wsRD.Range("K" & lastrow + 1).Value
wsRD.Range("B3").Copy wsRD.Range("L" & lastrow + 1).Value
wsRD.Range("E2").Copy wsRD.Range("M" & lastrow + 1).Value
wsRD.Range("E3").Copy wsRD.Range("N" & lastrow + 1).Value
wsRD.Range("H2").Copy wsRD.Range("O" & lastrow + 1).Value
wsRD.Range("H3").Copy wsRD.Range("P" & lastrow + 1).Value
wsRD.Range("Q1:T1").Copy wsRD.Range("Q" & lastrow + 1)
Application.ScreenUpdating = False
End With
End Sub
You can "copy" without actually using .Copy like this:
Sub CopyWithoutCopying()
Dim wsRD As Worksheet
Dim lastrow As Long
Set wsRD = Sheets("Raw Data")
With wsRD
lastrow = .Range("J" & .Rows.Count).End(xlUp).Row
.Range("K" & lastrow + 1).Value = .Range("B2").Value
.Range("L" & lastrow + 1).Value = .Range("B3").Value
' etc...
End With
End Sub
This approach doesn't use your clipboard, performs better, and doesn't select anything. And as Jimmy points out, you don't need the wsRD prefix inside the With block.