i have code which finds the last non empty row in an existing excel file. i want to insert data from 5 textbox to the next 5cells in column. i dont know how to code it. please help me, here is my code:
With xlWorkSheet
If EXL.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A2"), _
LookAt:=Excel.XlLookAt.xlPart, _
LookIn:=Excel.XlFindLookIn.xlFormulas, _
SearchOrder:=Excel.XlSearchOrder.xlByRows, _
SearchDirection:=Excel.XlSearchDirection.xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
End With
Here are two different solutions to your problem. I like the second better because you can determine a lastrow from any column and if you cared reference it to another column.
Dim nextrow As Integer = excel.Rows.End(XlDirection.xlDown).Row + 1
Dim ws As Worksheet = excel.ActiveSheet
Dim nRow = ws.Range("A" & ws.Rows.Count).End(XlDirection.xlUp).Row + 1
Then all you have to do to assign a value is:
excel.Range("A" & nRow).Value = "test"
excel.range("B" & nRow).value = "adjacent column"
If you want to loop it to 5 cells below that then do:
Dim ws As Worksheet = excel.ActiveSheet
Dim lRow = ws.Range("A" & ws.Rows.Count).End(XlDirection.xlUp).Row
For i = 1 To 5
excel.Range("A" & lRow).Offset(i, 0).Value = "variable here"
Next
Related
i would like to come up with vba sub that searching value from one specified cell (job) across all sheets and then pastes rows but only with selected columns. If value not found any error message instead paste value.
I know it's bigger project but I'm fresh so try to my best.
As far i have solution for whole rows:
Sub TEST()
Dim tws As String
Dim l_row As String
Dim l_rowR As String
Dim job As String
Dim i As Integer
Set tws = ThisWorkbook.Sheets("Data")
tws.Range("A20") = "STATS:"
job = tws.Range("B5")
lastRow = Worksheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Row
lastRowRpt = tws.Range("A" & Rows.Count).End(xlUp).Row
For i = 3 To lastRow
If Worksheets("Sheet1").Range("E" & i).Value = job And _
Worksheets("Sheet1").Range("D" & i).Value = "x2" Then
Worksheets("Sheet1").Rows(i).Copy
lastRowRpt = tws.Range("A" & Rows.Count).End(xlUp).Row
tws.Range("A" & lastRowRpt + 1).Select
tws.Paste
End If
Next i
End Sub
I am not an expert on excel vba, but need to assistance with it.
I have an excel worksheet currently with two sheets
"Datas" sheet : All my long list of data (click to see) is here.
"Template" sheet. A template (click to see) i created to format my data
I know this is going to be bulky.
I need a macro, or button that
can create a new sheet based on the template above for each line in the Column A value in "Datas" sheet
the name of the new sheet will be taken from the Column A value in "Datas" sheet
The new sheet should retain the formatting of the template after data has been copied
In summary it should look somewhat like this
this (click to see) for the first line in column A of Datas sheet
and this (click to see) for the second line in column A of Datas Sheet.
Here is a sample of the worksheet uploaded on
https://ufile.io/bxwo6
I have infact tried the following
http://sites.madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/sheet1-to-sheets
PART 2 - Parse New Data To New Sheets (macro)
It did the job of taking each line and split it into different sheets. The results are
This is my Data sheet
This is the result of the split which is good
I am somehow stuck on how to make it adapt to my template formatting.
I would be grateful if you could provide any tip, help or suggestion that i can try
Many Thanks
UPDATE:
I have tried the following code. create a copy of the template and rename it according to the value in Column A from the source
Sub AutoAddSheet()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Datas").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets("TEMPLATE").Copy After:=Sheets(Sheets.Count) 'Create a new worksheet as a copy of Sheet number 9 in this example
Sheets(Sheets.Count).Name = MyCell.Value 'Renames the new worksheets
Next MyCell
End Sub
UPDATE 2: This is the code that i modified from the link above. Note we cannot rename the sheets using column ":" value therefore, i modified my source by changing it from 1:1 into 1, 1:2 into 2
Option Explicit
Sub ParseItems()
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long, NR As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long, Append As Boolean
Application.ScreenUpdating = False
'Column to evaluate from, column A = 1, B = 2, etc.
vCol = 1
'Sheet with data in it
Set ws = Sheets("Data")
'option to append new data below old data
If MsgBox(" If sheet exists already, add new data to the bottom?" & vbLf & _
"(if no, new data will replace old data)", _
vbYesNo, "Append new Data?") = vbYes Then Append = True
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
vTitles = "A1:Z1"
TitleRow = Range(vTitles).Cells(1).Row
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Get a temporary list of unique values from vCol
iCol = ws.Columns.Count
ws.Cells(1, iCol) = "key"
For Itm = TitleRow + 1 To LR
On Error Resume Next
If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
.Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
End If
Next Itm
'Sort the temporary list
ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Put list into an array for looping
MyArr = Application.WorksheetFunction.Transpose _
(ws.Columns(iCol).SpecialCells(xlCellTypeConstants))
'clear temporary list
ws.Columns(iCol).Clear
'Turn on the autofilter
ws.Range(vTitles).AutoFilter
'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
For Itm = 2 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=CStr(MyArr(Itm))
If Not Evaluate("=ISREF('" & CStr(MyArr(Itm)) & "'!A1)") Then 'create sheet if needed
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(MyArr(Itm))
NR = 1
Else 'if it exists already
Sheets(CStr(MyArr(Itm))).Move After:=Sheets(Sheets.Count) 'ordering the sheets
If Append Then 'find next empty row
NR = Sheets(CStr(MyArr(Itm))).Cells(Rows.Count, vCol).End(xlUp).Row + 1
Else
Sheets(CStr(MyArr(Itm))).Cells.Clear 'clear data if not appending
NR = 1
End If
End If
If NR = 1 Then 'copy titles and data
ws.Range("A" & TitleRow & ":A" & LR).EntireRow.Copy Sheets(CStr(MyArr(Itm))).Range("A" & NR)
Else 'copy data only
ws.Range("A" & TitleRow + 1 & ":A" & LR).EntireRow.Copy Sheets(CStr(MyArr(Itm))).Range("A" & NR)
End If
ws.Range(vTitles).AutoFilter Field:=vCol 'reset the autofilter
If Append And NR > 1 Then NR = NR - 1
MyCount = MyCount + Sheets(CStr(MyArr(Itm))).Range("A" & Rows.Count).End(xlUp).Row - NR
Sheets(CStr(MyArr(Itm))).Columns.AutoFit
Next Itm
'Cleanup
ws.Activate
ws.AutoFilterMode = False
MsgBox "Rows with data: " & (LR - TitleRow) & vbLf & "Rows copied to other sheets: " _
& MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub
This should give you an idea which you can start with. It loops through the datas and for each data row it copies the template, renames it and fills in the data row into specific ranges.
Option Explicit
Public Sub AutoParseItems()
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("Datas")
Dim lRow As Long
lRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row 'find last row in column A
Const fRow As Long = 1 'set first data row
Dim iRow As Long
For iRow = fRow To lRow 'loop throug data rows
'create a copy of the sheet
ThisWorkbook.Worksheets("TEMPLATE").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Dim wsNewTemplateCopy As Worksheet
Set wsNewTemplateCopy = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'determine new sheet name and rename the sheet
With wsData.Cells(iRow, "A")
wsNewTemplateCopy.Name = Right$(.Text, Len(.Text) - InStr(1, .Text, ":")) 'find : to determine new sheet name
End With
'fill in the text into the new sheet
wsNewTemplateCopy.Range("A1").Value = wsData.Cells(iRow, "A").Value
wsNewTemplateCopy.Range("A5").Value = wsData.Cells(iRow, "C").Value
wsNewTemplateCopy.Range("A22").Value = wsData.Cells(iRow, "D").Value
'modify the ranges where you need your data
Next iRow
End Sub
So I wrote a VBA code to calculate the number of blanks, non-blanks and total entries under each header for some input data. I want to add a code that copies and pastes the values from one sheet to another, dedupes the values, gives me the unique list of values under each header, number of unique values, and the number of times those unique values are occurring under the header.
Blanks: I used the countblank function earlier, but it would skip certain empty fields, so I changed it to sumproduct(len(Range)=0)*1).
Non-Blanks: I wrote a similar function and tried to calculate the above.
It turns out VBA is unable to process the Sumproduct function. Here are the approaches I have tried:
1. Application.WorksheetFunction.Sumproduct(...)
2. ..Number.. = "=Sumproduct(...)"
3. ..Number.. = Evaluate("Sumproduct(...)")
4. ..Number.. = Worksheet.Evaluate("Sumproduct(...)")
Below is the code for the macro, I am writing the code on the Input_File, i.e., the Input worksheet.
Sub Dedupe()
ThisWorkbook.Worksheets("Control_Totals").Cells.ClearContents
Dim lRow As Long
Dim lCol As Long
Dim i As Long
Dim j As Long
Dim Input_File As Worksheet
Dim Output_File As Worksheet
Dim Dedup_File As Worksheet
Dim Col_Let As String
Dim Rng As String
Dim blank As String
Dim non_blank As String
Set Input_File = ThisWorkbook.Worksheets("Input")
Set Output_File = ThisWorkbook.Worksheets("Control_Totals")
Set Dedup_File = ThisWorkbook.Worksheets("Deduped")
With Output_File
.Cells(1, 1) = "Field_Name"
.Cells(1, 2) = "Blanks"
.Cells(1, 3) = "Non-Blanks"
.Cells(1, 4) = "Total"
End With
'Finding the last row among all entries, including the blank ones
lRow = Input_File.Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
MsgBox "Last Row: " & lRow
'Finding the last column header/field
lCol = Input_File.Cells.Find(What:="*", _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
MsgBox "Last Column: " & lCol
i = 1
'Finding the number of blank and non-blank entries for all the fields
Do While i < lCol + 1
Col_Let = ColumnLetter(i)
Rng = "Input!" & "Col_Let" & "2" & ":" & "lRow"
Output_File.Cells(i + 1, 1) = Input_File.Cells(1, i)
blank = "SumProduct((Len(Rng) = 0) * 1)"
non_blank = "SumProduct((Len(Rng) > 0) * 1)"
Output_File.Cells(i + 1, 2).Value = Evaluate(blank)
Output_File.Cells(i + 1, 3).Value = Evaluate(non_blank)
Output_File.Cells(i + 1, 4) = lRow - 1
'Deduping the data under the headers
j = 0
For j = 1 To lRow
Dedup_File.Cells(j, i).Value = Input_File.Cells(j, i).Value
j = j + 1
Next
Dedup_File.Range(Cells(1, i), Cells(lRow, i)).RemoveDuplicates Columns:=1, _
Header:=xlYes
i = i + 1
Loop
End Sub
These lines don't do what you think they do
Col_Let = ColumnLetter(i)
Rng = "Input!" & "Col_Let" & "2" & ":" & "lRow"
Rng is always a string containing "Input!Col_Let2:lRow"
What you meant was: (I think)
Rng = "Input!" & Col_Let & "2" & ":" & Col_Let & lRow
Secondly Rng exists only within this vba routine - it doesn't mean anything to Excel so you can't use it in an Excel Formula. You need
blank = "SumProduct((Len(" & Rng.address & ") = 0) * 1)"
and finally SumProduct doesn't like those sort of tricks in VBA (It relies on excel expanding the 1 into an array automatically). A better solution:
Dim cBlank as long
Dim cNonBlank as long
Dim r as range
For each r in rng
if r.text = "" then
cBlank= cBlank+1
else
cNonBlank = cNonBlank +1
end if
next r
I want to add a code that copies and pastes the values from one sheet to another, dedupes the values, gives me the unique list of values under each header, number of unique values, and the number of times those unique values are occurring under the header.
What you have just described there is a PivotTable, with the field of interest in both the Rows area and in the Values area as a Count.
My original question was posted here.
Basically I needed some help transferring data from one sheet to another based on values in the first sheet. I am using a modified bit of code provided by user keong kenshih.
I added an additional check against another row to the IF statement, and I have this for my code:
Option Explicit
Dim MyWorkbook As Workbook
Dim MyWorksheet As Worksheet
Dim MyOutputWorksheet As Worksheet
So I need to output only certain columns. Also I need them to import to certain rows and columns on the second sheet, the CONTRACT sheet. Column A on the MAIN sheet goes to column A starting at row 17 on the CONTRACT sheet. B to B , E to D, F to E, all starting at row 17 on the CONTRACT sheet.
Rows 17-42 on the CONTRACT sheet will contain data.
Sub PullData()
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set MyWorksheet = MyWorkbook.Sheets("MAIN")
Set MyOutputWorksheet = MyWorkbook.Sheets("CONTRACT")
Dim myValue As Long
Dim RowPointer As Long
For RowPointer = 6 To MyWorksheet.Cells(Rows.Count, "B").End(xlUp).Row
If MyWorksheet.Range("A" & RowPointer).V alue > 0 And
MyWorksheet.Range("A" & RowPointer).Value <> ""
MyWorksheet.Range("F" & RowPointer).Value > 0 And
MyWorksheet.Range("F" & RowPointer).Value <> ""Then
If MyOutputWorksheet.Cells(Rows.Count, "B").End(xlUp).Row > 15
Then
Exit Sub
End If
MyWorksheet.Range(("A" & RowPointer) & ":C" & RowPointer).Copy
Destination:=MyOutputWorksheet.Range("A" &
MyOutputWorksheet.Cells(Rows.Count, "B").End(xlUp).Row + 1)
End If
Next RowPointer
End Sub
Give this a try :
Sub PullData()
Dim wRow As Long, _
RowPointer As Long, _
MyWorkbook As Workbook, _
Ws As Worksheet, _
OutWs As Worksheet
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set Ws = MyWorkbook.Sheets("MAIN")
Set OutWs = MyWorkbook.Sheets("CONTRACT")
With Ws
For RowPointer = 6 To .Cells(.Rows.Count, "B").End(xlUp).Row
If .Range("A" & RowPointer).Value > 0 And _
.Range("A" & RowPointer).Value <> "" And _
.Range("F" & RowPointer).Value > 0 And _
.Range("F" & RowPointer).Value <> "" Then
'This line would get you out of the loop after the first copy because _
'You first paste on line 17 and then the below left part will be equal to 18
'If OutWs.Cells(OutWs.Rows.Count, "B").End(xlUp).Row > 15 Then Exit Sub
wRow = OutWs.Rows(OutWs.Rows.Count).End(xlUp).Row + 1
'Always start copy after (or at) line 17
If wRow <= 17 Then wRow = 17
'More efficient way to copy data between ranges
OutWs.Range("A" & wRow).Value = Ws.Range("A" & RowPointer)
OutWs.Range("B" & wRow).Value = Ws.Range("B" & RowPointer)
OutWs.Range("D" & wRow).Value = Ws.Range("E" & RowPointer)
OutWs.Range("E" & wRow).Value = Ws.Range("F" & RowPointer)
End If
Next RowPointer
End With
Set MyWorkbook = Nothing
Set Ws = Nothing
Set OutWs = Nothing
End Sub
Dim RITMRow As Long
Dim ws1 As Worksheet
Dim RITMstorage As String
Dim LastRow As Long
Set ws1 = Sheets("Tracker")
LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row
For RITMRow = 2 To LastRow
RITMstorage = ws1.Range("A" & RITMRow).Value
ws1.Range("A" & RITMRow).Hyperlinks.Add Anchor:=ws1.Range("A" & RITMRow), _
Address:="https://site.site.com/sc_req_item.do?sys_id=" & RITMstorage, _
ScreenTip:="Request Number", _
TextToDisplay:=RITMstorage
Next RITMRow
With ws1
.Cells.Font.Size = "8"
.Cells.RowHeight = 11.25
.Cells.Font.Name = "Calibri"
.Range("A1").EntireRow.RowHeight = 25
End With
hi, my code above works in converting a column to hyperlinks. as you can see, it's quite a bit inefficient as everytime i click the button, it goes back and converts everything to hyperlinks again, even those that are already hypelinks. please point me in the right direction. i need a way to detect the columns that already has a hyperlink the offset by 1 then convert the non hyperlink cell.
thanks in advance.
Just try to get the address from the cell and check to see if you get an error:
Dim url As String
Dim isLink As Boolean
For RITMRow = 2 To LastRow
On Error Resume Next
url = ws1.Range("A" & RITMRow).Hyperlinks(1).SubAddress
isLink = (Err.Number = 0)
On Error GoTo 0
If Not isLink Then
RITMstorage = ws1.Range("A" & RITMRow).Value
ws1.Range("A" & RITMRow).Hyperlinks.Add Anchor:=ws1.Range("A" & RITMRow), _
Address:="https://site.site.com/sc_req_item.do?sys_id=" & RITMstorage, _
ScreenTip:="Request Number", _
TextToDisplay:=RITMstorage
End If
Next RITMRow