I'm using this code for add new items to next blank line.
Private Sub Ekle_Butonu_Click()
Dim LastRow As Long, ws As Worksheet
Set ws = Sayfa1
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range("A" & LastRow).Value = Tarih_B
ws.Range("C" & LastRow).Value = Kaynak_B
ws.Range("E" & LastRow).Value = Aciklama_B
ws.Range("I" & LastRow).Value = Tutar_B
End Sub
And I want to print just this added line. Can you help me ?.
You need to look into the PageSetup.PrintArea property. For example:
Sub Test()
Dim lr As Long
With Sayfa1
lr = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(lr, 1).Value = Tarih_B
.Cells(lr, 3).Value = Kaynak_B
.Cells(lr, 5).Value = Aciklama_B
.Cells(lr, 9).Value = Tutar_B
.PageSetup.PrintArea = Replace("A?,C?,E?,I?", "?", lr)
.PrintOut
End With
End Sub
As per your comment, If I understand you correctly, there are more cells in that same line you want to include:
.PageSetup.PrintArea = Replace("A?:J?", "?", lr)
Related
I'm trying to make a macro which calls other macros (like the one below) and applies them to specified sheets.
I think the problem is that my previously made macros in which it calls upon isn't coded correctly to be applied to sheets it's not actively on.
Here is my code:
Sub limits_Monitoring_bores()
Dim sht As Worksheet, lastRow As Long
Set sht = ActiveWorkbook.Worksheet
'Name columns appropriately
With ActiveWorkbook.Worksheets(1)
.Cells(1, 4).Value = "Min"
.Cells(1, 5).Value = "Max"
.Cells(1, 7).Value = "20th Percentile"
.Cells(1, 8).Value = "80th Percentile"
.Cells(1, 10).Value = "20th Percentile"
.Cells(1, 11).Value = "80th Percentile"
End With
lastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
sh.Range("D2:D" & lastRow).Value = "=6"
sh.Range("E2:E" & lastRow).Value = "=8.5"
sh.Range("G2:G" & lastRow).Value = "=PERCENTILE(F:F,0.2)"
sh.Range("H2:H" & lastRow).Value = "=PERCENTILE(F:F,0.8)"
sh.Range("J2:J" & lastRow).Value = "=PERCENTILE(I:I,0.2)"
sh.Range("K2:K" & lastRow).Value = "=PERCENTILE(I:I,0.8)"
I'm trying to do the following with VBA. Imagine I have some data as it follows:
I would like my final result to be the sum of every data that is between "BEGINDATA" and "ENDDATA". So it would look like this:
My goal is to obtain the green data and write it next to "ENDDATA"
Any idea or suggestion?
Thank you so much!!
Try:
Option Explicit
Sub test()
Dim Lastrow As Long, BeginData As Long, EndData As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
If .Range("A" & i).Value = "BEGINDATA" Then
BeginData = i
ElseIf .Range("A" & i).Value = "ENDDATA" Then
EndData = i
End If
If EndData > BeginData Then
.Range("B" & i).Value = Application.Sum(.Range("B" & BeginData + 1 & ":B" & EndData - 1))
End If
Next i
End With
End Sub
Another Version:
Option Explicit
Sub test()
Dim Lastrow As Long, BeginData As Long, EndData As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
If .Range("A" & i).Value = "BEGINDATA" Then
BeginData = i
ElseIf .Range("A" & i).Value = "ENDDATA" Then
EndData = i
End If
If EndData > BeginData Then
With .Range("B" & i)
.Value = Application.Sum(Sheet1.Range("B" & BeginData + 1 & ":B" & EndData - 1))
.Interior.Color = vbGreen
End With
End If
Next i
End With
End Sub
You can also achieve this using Find which will be faster then looping
Option Explicit
Sub Demo()
Dim BeginData As Range, EndData As Range
Dim FirstBeginAddress As String
' Update with your range
With Sheet1.Columns(1)
Set BeginData = .Find(what:="BEGINDATA", after:=.Cells(.Cells.Count), LookIn:=xlValues, lookat:=xlWhole)
If Not BeginData Is Nothing Then
FirstBeginAddress = BeginData.Address
Set EndData = .Find("ENDDATA", after:=BeginData)
Do
Debug.Print "BeginAddress", BeginData.Address
If Not EndData Is Nothing And EndData.Row > BeginData.Row Then
Debug.Print "EndAddress", EndData.Address
'' For Formula
EndData.Offset(0, 1).Formula = "=SUM(" & Range(BeginData.Offset(1, 1), EndData.Offset(-1, 1)).Address & ")"
'' For value
'EndData.Offset(0, 1).Value2 = Application.Sum(Range(BeginData.Offset(1, 1), EndData.Offset(-1, 1)))
Set EndData = .Find("ENDDATA", after:=EndData)
Else
Err.Raise 998, "Demo", "Unable to find Data Footer"
End If
Set BeginData = .Find("BEGINDATA", after:=BeginData)
Loop Until BeginData Is Nothing Or BeginData.Address = FirstBeginAddress
Else
Err.Raise 999, "Demo", "Unable to find Data Header"
End If
End With
End Sub
This is a follow on from How do I get all the different unique combinations of 3 columns using VBA in Excel?
It almost what i need, however, my requirements is that it sums the third column which will contain figures instead of yes/no
Sub sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim col As New Collection
Dim Itm
Dim cField As String
Const deLim As String = "#"
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
cField = .Range("A" & i).Value & deLim & _
.Range("B" & i).Value & deLim & _
.Range("C" & i).Value
On Error Resume Next
col.Add cField, CStr(cField)
On Error GoTo 0
Next i
i = 2
.Range("A1:C1").Copy .Range("F1")
.Range("I1").Value = "Count"
For Each Itm In col
.Range("F" & i).Value = Split(Itm, deLim)(0)
.Range("G" & i).Value = Split(Itm, deLim)(1)
.Range("H" & i).Value = Split(Itm, deLim)(2)
For j = 2 To lRow
cField = .Range("A" & j).Value & deLim & _
.Range("B" & j).Value & deLim & _
.Range("C" & j).Value
If Itm = cField Then nCount = nCount + 1
Next
.Range("I" & i).Value = nCount
i = i + 1
nCount = 0
Next Itm
End With
End Sub
This code was originally added by
Siddharth Rout
try this (follows comments)
Option Explicit
Sub Main()
Dim i As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For i = 4 To Range("A" & Rows.Count).End(xlUp).Row '<-- change 4 and "A" to your data actual upleftmost cell row and column
dict(cells(i, 1).Value & "|" & cells(i, 2).Value) = dict(cells(i, 1).Value & "|" & cells(i, 2).Value) + cells(i, 3).Value '<--| change 3 to your actual "column to sum up" index
Next
With Range("G3").Resize(dict.Count) '<-- change "G3" to your actual upleftmost cell to start writing output data from
.Value = Application.Transpose(dict.Keys)
.TextToColumns Destination:=.cells, DataType:=xlDelimited, Other:=True, OtherChar:="|"
.Offset(, 2).Resize(dict.Count).Value = Application.Transpose(dict.Items) '<--| change 2 to your actual column offset where to start writing summed values form
End With
End Sub
I am new to Macros. I need excel macro code for the below logic:
col1 means column1,
col2 means column2
Sub TestDuplicates()
in worksheet,
for(each x = row) {
for(each y = row+1) {
if(x.col1 == y.col1 && x.col3 == y.col4 && x.col4 == y.col3) {
Delete y
}
}
}
End Sub
Sub deleteDuplicateRows()
Dim ws As Worksheet
Dim lastRow As Long, curRow As Long, checkRow As Long
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row - 1
For curRow = 2 To lastRow
For checkRow = curRow + 1 To lastRow
If ws.Range("A" & curRow).Value = ws.Range("A" & checkRow).Value And ws.Range("B" & curRow).Value = ws.Range("B" & checkRow).Value And ws.Range("C" & curRow).Value = ws.Range("C" & checkRow).Value Then
ws.Rows(checkRow).Delete
End If
Next checkRow
Next curRow
End Sub
Checks the current row against all remaining rows starting at row 2.
Sub TestDuplicates()
Dim ws As Excel.Worksheet
Dim lRow As Long
lRow = 1
Do While lRow <= ws.UsedRange.Rows.count
If ws.Range("A" & lRow).Value = ws.Range("A" & lRow + 1).Value And ws.Range("C" & lRow).Value = ws.Range("D" & lRow + 1).Value And ws.Range("D" & lRow).Value = ws.Range("C" & lRow + 1).Value then
ws.Rows(lRow).EntireRow.Delete
End If
lRow = lRow + 1
ws.Range("A" & lRow).Activate
Loop
End Sub
EDIT: I seem to have misunderstood your pseudocode somewhat, so this doesn't do quite what you asked. Instead, it compares each row to the row directly after it, not to all remaining rows. Since bbishopca already contributed an excellent solution to what you actually asked for, I'll just leave this here unedited in case someone finds it useful.
Sub AlmostTestDuplicates()
Dim ws As Worksheet
Dim rw As Range
Set ws = ActiveSheet
For Each rw In ws.Rows
If ws.Cells(rw.Row, 1).Value = "" Then
Exit Sub
End If
If Cells(rw.Row, 1) = Cells(rw.Row + 1, 1) _
And Cells(rw.Row, 3) = Cells(rw.Row + 1, 4) _
And Cells(rw.Row, 4) = Cells(rw.Row + 1, 3) Then
ws.Rows(rw.Row + 1).Delete
End If
Next rw
End Sub
I recorded a macro that VLOOKUPs from Sheet "P&L" (the first tab that holds all of the data) and filters down in the current sheet until the data in column A runs out. It works; however, I need this code to function for the remaining sheets. These are updated monthly. There will be a different number of inputs in Column A in each sheet. These are all ID #s I'm using to vlookup information from the P&L tab.
When I wrote this macro as a FoorLoopIndex, I keep getting "Compile error: invalid or unqualified" messages.
I do not have any experiences with macros -- I'm struggling to find my error.
Sub update_gp_profits()
Dim StartIndex, EndIndex, LoopIndex As Integer
StartIndex = Sheets("P&L").Index + 1
EndIndex = Sheets("Sheet4").Index - 1
For LoopIndex = StartIndex To EndIndex
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("B2:B" & lastrow).Formula = "=+VLOOKUP(RC[-1],'P&L'!R15C3:R29702C4,2,FALSE)"
Range("C2").Select
.Range("C2:C" & lastrow).Formula = "=+VLOOKUP(RC[-2],'P&L'!R15C3:R29702C5,3,FALSE)"
Range("D2").Select
.Range("D2:D" & lastrow).Formula = "=+VLOOKUP(RC[-3],'P&L'!R15C3:R29702C6,4,FALSE)"
Range("E2").Select
.Range("E2:E" & lastrow).Formula = "=+VLOOKUP(RC[-4],'P&L'!R15C3:R29702C17,15,FALSE)"
Range("F2").Select
.Range("F2:F" & lastrow).Formula = "=+VLOOKUP(RC[-5],'P&L'!R15C3:R29702C18,16,FALSE)"
Range("J2").Select
.Range("k2:k" & lastrow).Formula = "=+VLOOKUP(RC[-10],'P&L'!R15C3:R29702C160,158,FALSE)"
Range("k2").Select
Next LoopIndex
End Sub
Try this one,
Sub update_gp_profits()
Dim ws As Worksheet
Dim rng As Range
Dim lRow As Long
Set ws = ActiveSheet
'
With ws
lRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' Last row
Set rng = .Range("A2" & ":" & "A" & lRow) ' This is your range
rng.Offset(0, 1).FormulaR1C1 = "=VLOOKUP(RC[-1],'P&L'!R15C3:R29702C4,2,FALSE)"
rng.Offset(0, 2).FormulaR1C1 = "=VLOOKUP(RC[-2],'P&L'!R15C3:R29702C5,3,FALSE)"
rng.Offset(0, 3).FormulaR1C1 = "=VLOOKUP(RC[-3],'P&L'!R15C3:R29702C6,4,FALSE)"
rng.Offset(0, 4).FormulaR1C1 = "=VLOOKUP(RC[-4],'P&L'!R15C3:R29702C17,15,FALSE)"
rng.Offset(0, 5).FormulaR1C1 = "=VLOOKUP(RC[-5],'P&L'!R15C3:R29702C18,16,FALSE)"
rng.Offset(0, 10).FormulaR1C1 = "=VLOOKUP(RC[-10],'P&L'!R15C3:R29702C160,158,FALSE)"
Debug.Print rng.Address
End With
End Sub
Try below code it will loop all the rows on the sheet4.
max num of row in 2010 office = https://stackoverflow.com/a/527026/1411000
https://stackoverflow.com/a/527026/1411000
Sub update_gp_profits()
Dim StartIndex, EndIndex, LoopIndex As Integer
StartIndex = Sheets("Sheet4").).Index + 1
EndIndex = 1048576
For LoopIndex = StartIndex To EndIndex
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("B2:B" & lastrow).Formula = "=+VLOOKUP(RC[-1],'P&L'!R15C3:R29702C4,2,FALSE)"
Range("C2").Select
.Range("C2:C" & lastrow).Formula = "=+VLOOKUP(RC[-2],'P&L'!R15C3:R29702C5,3,FALSE)"
Range("D2").Select
.Range("D2:D" & lastrow).Formula = "=+VLOOKUP(RC[-3],'P&L'!R15C3:R29702C6,4,FALSE)"
Range("E2").Select
.Range("E2:E" & lastrow).Formula = "=+VLOOKUP(RC[-4],'P&L'!R15C3:R29702C17,15,FALSE)"
Range("F2").Select
.Range("F2:F" & lastrow).Formula = "=+VLOOKUP(RC[-5],'P&L'!R15C3:R29702C18,16,FALSE)"
Range("J2").Select
.Range("k2:k" & lastrow).Formula = "=+VLOOKUP(RC[-10],'P&L'!R15C3:R29702C160,158,FALSE)"
Range("k2").Select
Next LoopIndex
End Sub