I have such case, I want to sum two diffrent rows but I dont want to sum values in some colums.
For example I want to sum row 6 and 7 but without datas in columns with name "Charge", do you have any clue?
Range("e5").Select
Do
If ActiveCell.Value <> ActiveCell.Offset(1#).Value Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(0, 3).Select
If ActiveCell.Value <> ActiveCell.Offset(1#).Value Then
ActiveCell.Offset(1, -3).Select
Else
Rows(ActiveCell.Row).Select
Selection.Copy
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
ActiveCell.Offset(-1, 0).Select
Rows(ActiveCell.Row).Select
Selection.Delete
ActiveCell.Offset(0, 4).Select
End If
End If
Loop Until ActiveCell.Value = ""
Related
I'm trying to get a loop with multiple if/else statements to work but it keeps saying either I have Ifs with no End Ifs or that I have a Loop with no Do.
Any pointers would be great.
Below is the what I've done so far, please go easy on me I only started trying to write in vba yesterday...
Sub EditTransposeCopy()
Sheets("Altered").Select
Dim count As Long
count = WorksheetFunction.CountA(Range("A6", Range("A6").End(xlDown))) - 1
Do While count > 0
If InStr(1, (Range("A23").Value), "Reason:") > 0 Then
Rows("9:11").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Rows("14").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Rows("16").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Rows("18").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A7:A18").Select
Selection.Copy
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A6:N6").Copy
Sheets("Output").Range("A" & Rows.count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Sheets("Altered").Select
Rows("6:18").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
count = count - 19
Else
If InStr(1, (Range("A20").Value), "Reason:") > 0 Then
Rows("9:11").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Rows("14").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Rows("16").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A7:A16").Select
Selection.Copy
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A6:L6").Copy
Sheets("Output").Range("A" & Rows.count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Sheets("Altered").Select
Rows("6:16").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
count = count - 16
Else
If InStr(1, (Range("A17").Value), "Reason:") > 0 Then
Rows("9:11").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Rows("14").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A7:A14").Select
Selection.Copy
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A6:J6").Copy
Sheets("Output").Range("A" & Rows.count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Sheets("Altered").Select
Rows("6:14").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
count = count - 13
Else
If InStr(1, (Range("A15").Value), "£0.00") > 0 Then
Sheets("Altered").Select
Rows("9:11").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A7:A12").Select
Selection.Copy
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A6:H6").Copy
Sheets("Output").Range("A" & Rows.count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Sheets("Altered").Select
Rows("6:12").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
count = count - 10
Else
count = count - 10000000
End If
Loop
'
End Sub
Thanks in advance
Use ElseIf or terminate each If block with an End If
Sub EditTransposeCopy()
'...
Do While count > 0
If InStr(1, (Range("A23").Value), "Reason:") > 0 Then
'...
ElseIf InStr(1, (Range("A20").Value), "Reason:") > 0 Then
'...
ElseIf InStr(1, (Range("A15").Value), "£0.00") > 0 Then
'...
Else
'...
End If
Loop
End Sub
Welcome to SO, and welcome to VBA!
First up, you should look at how to avoid using select, because although this is how the macro recorder works, it's better practice (less prone to bugs) and more readable if you replace code like
Range("A1").Select
Selection.Copy
with
Range("A1").Copy
Secondly look up the syntax of an if statement - in particular this part about use of Else If will be handy in the above code. Each If requires it's own End If, looks like you missed a couple in your original code.
I try
Do
Selection.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=R[-1]C+0.01"
Loop Until ActiveCell.Value = "$C$1"
But it's not working
Pls. help
i try to add + 0.01 from first value (1) until equal last value (1.9)
Here is my all code
[Sub ExtractRC()
Range("A2:A" & Range("A2").End(xlDown).Row).Select
Cells(Rows.Count, "A").End(xlUp).Select
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues
Range("k2").Select
ActiveCell.FormulaR1C1 = Range("A2").Value
Do
Selection.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=R\[-1\]C+0.01"
Loop Until ActiveCell.Value = "$C$1"
End Sub][1]
P.S. Value in Column A can change
I receive data that is similar in content, yet varies in the number and order of columns. I installed a drop down permanently in A6, copying it to each column in row 6,of the other columns, then select the appropriate header from the list. How can I amend my macro so it would either copy the DV from A6 or create identical headers where required? (determined by countA in Row 5)
This VBA solution places text where I want the dropdowns. Please tell me what I should use to replace the text "same dropdown as A6" so that it will automatically insert a dropdown with the header choices.
Private Sub CmdSubmit_Click()
Dim i As Integer
For i = 1 To 50
ActiveSheet.Select
Range("A5").Select
If ActiveCell.Offset(0, 1).Value >= "1" Then
ActiveCell.Offset(1, 0).Select
Else
Selection.End(xlToLeft).Offset(0, 1).Select
End If
ActiveCell.Offset(0, 1).Value = "same drop down as A6"
ActiveCell.Offset(0, 2).Value = "same drop down as A6"
ActiveCell.Offset(0, 3).Value = "same drop down as A6"
ActiveCell.Offset(0, 4).Value = "Same drop down as A6"
Next i
End Sub
This works, but it is not dynamic: Can we make it dynamic?
Sub Thiscopypaste()
Dim rngcopy As Range
Dim i As Integer
Set rngcopy = ActiveSheet.Range("A6")
rngcopy.Copy
Range("B5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Range("C5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Range("D5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Range("E5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Range("F5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
End Sub
If the dropdown you speak of is a data validation list then you need to perform the following:
Private Sub CmdSubmit_Click()
Dim i As Integer
Dim rngCopy As Range
For i = 1 To 50
'ActiveSheet.Select
Set rngCopy = ActiveSheet.Range("A6")
rngCopy.Copy
If rngCopy.Offset(-1, i).Value >= 1 Then
'ActiveCell.Offset(1, 0).Select
rngCopy.Offset(0, i).PasteSpecial xlPasteAll
Else
Set rngCopy = rngCopy.End(xlToLeft).Offset(0, i)
End If
'rngCopy.Offset(0, i).PasteSpecial xlPasteAll
'rngCopy.Offset(0, 2).PasteSpecial xlPasteAll
'rngCopy.Offset(0, 3).PasteSpecial xlPasteAll
'rngCopy.Offset(0, 4).PasteSpecial xlPasteAll
Next i
Set rngCopy = Nothing
End Sub
I'm looking for a VBA code that will look in the 2nd row for specific dates.
Basically, I'm writing a "Begin" date (ex: 2018-07-01) and an "End" date (ex: 2018-07-31) and I want my code to look for everything in between, including those dates, and copy paste all the information in another excel sheet. What the function will do at the end is it'll look into many sheets for those dates and copy every bit of information that are below those dates, and paste them all into one main sheet.
What I'm attaching below is what I've done so far:
Sub Copie()
Sheets("1").Select
Range("B1:H1").Select
Selection.Copy
Sheets("Per Employe").Select
Range("A4").Select
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste
Sheets("1").Select
Range("J1:P1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Per Employe").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste
Sheets("1").Select
Cells(1, 1).Select
ActiveCell.Offset(1, 0).Select
Selection.Copy
Sheets("Per Employe").Select
Cells(4, 1).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("1").Select
Range("B2:H2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Per Employe").Select
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste
Sheets("1").Select
Range("J2:P2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Per Employe").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste
End Sub
What I'm trying to add is the function to look up the dates and only copy/paste the dates that were asked for in the main excel sheet, which would be "Per Employe". Would anyone have any solution to this? The cells that contain the begin and end date would be D1 & F1.
This macro looks at a row, copies the content and pastes it into desired cells in certain sheets.
I´d like to make this macro code quicker because it takes too long.
The code loops over about 7000 rows.
Any help would be appreciated,
Here´s my code:
Sub Input_Template()
Application.ScreenUpdating = False
Sheets("Cost Gained").Select
Range("A1").Select
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select
Loop
Do
'Qc Note
ActiveCell.Offset(0, 0).Select
Selection.Copy
Sheets("Debit Note").Select
Range("G8,C6").Select
ActiveSheet.PasteSpecial
Range("C6").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(R[2]C[4], ""DN"")"
'Supplier Name
Sheets("Cost Gained").Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Debit Note").Select
Range("G11").Select
ActiveSheet.PasteSpecial
'RTV Number
Sheets("Cost Gained").Select
ActiveCell.Offset(0, 2).Select
Selection.Copy
Sheets("Debit Note").Select
Range("G16,C22").Select
ActiveSheet.PasteSpecial
'Cost
Sheets("Cost Gained").Select
ActiveCell.Offset(0, 2).Select
Selection.Copy
Sheets("Debit Note").Select
Range("G9,G22,G24,G26,G27").Select
ActiveSheet.PasteSpecial
'Supplier Code
Sheets("Cost Gained").Select
ActiveCell.Offset(0, 2).Select
Selection.Copy
Sheets("Debit Note").Select
Range("G10").Select
ActiveSheet.PasteSpecial
'PO Number
Sheets("Cost Gained").Select
ActiveCell.Offset(0, 2).Select
Selection.Copy
Sheets("Debit Note").Select
Range("G7").Select
ActiveSheet.PasteSpecial
'Suppplier Email
Sheets("Cost Gained").Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Debit Note").Select
Range("G15").Select
ActiveSheet.PasteSpecial
'Address
Sheets("Cost Gained").Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Debit Note").Select
Range("C9").Select
ActiveSheet.PasteSpecial
Sheets("Cost Gained").Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Debit Note").Select
Range("C10").Select
ActiveSheet.PasteSpecial
Sheets("Cost Gained").Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Debit Note").Select
Range("C11").Select
ActiveSheet.PasteSpecial
Sheets("Cost Gained").Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Debit Note").Select
Range("C12").Select
ActiveSheet.PasteSpecial
Sheets("Cost Gained").Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Debit Note").Select
Range("C13").Select
ActiveSheet.PasteSpecial
Sheets("Cost Gained").Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Debit Note").Select
Range("C14").Select
ActiveSheet.PasteSpecial
Sheets("Cost Gained").Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Debit Note").Select
Range("C15").Select
ActiveSheet.PasteSpecial
Range("G9").NumberFormat = "$#,##0.00"
Range("G15").Select
Selection.Style = "Hyperlink"
This contains code to add bold around an area, change font to arial size 16.
But is very long so I have left it out.
'Save as pdf once finish one row, then save pdf in a location then continue until row 299.
Sheets("Debit Note").Select
ChDir "P:\Perkins\Quality\COPQ\J Benge COPQ\MACROS\Debit Notes\"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"P:\Perkins\Quality\COPQ\J Benge COPQ\MACROS\Debit Notes\" & Range("G8").Value
'Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Sheets("Cost Gained").Select
ActiveCell.Select
ActiveCell.Offset(1, -17).Select
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select
Loop
Loop Until ActiveCell.Row = "299"
End Sub
You shoul get rid of the .Select and Selection. you don´t need them, they slow down code and can cause errors.
For Example:
Instead of
Sheets("Debit Note").Select
Range("G11").Select
ActiveSheet.PasteSpecial
You can write
Sheets("Debit Note").Range("G11").PasteSpecial
Just add these two lines at the beginning of Input_Template()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
And add these two lines before the End Sub
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
As you're not using any of the PasteSpecial paste types (such as xlPasteValues) then you could just use:
ThisWorkbook.Worksheets("Cost Gained").Cells(1, 2).Copy _
Destination:=ThisWorkbook.Worksheets("Debit Note").Cells(2, 1)
This copies from range B1 ( .Cells(1,2) - row 1, column 2) to A2 ( .cells(2,1) - row 2, column 1).