VBA - looking through each record - excel

Struggling a bit with this code, I haven't ever had to reference one column and copy and paste to another tab in VBA so here goes..
I have an excel document with a table on it similar to below:
I need my code to look in column A find the first name, in this case, Nicola. I then want it to look at column B and check to see if she has the word "Internet" appear in any of the records stored against her, as she does the code will ignore her and move down to the next name on the list, in this case, Graham. It will then look to column B and check if he has the word "Internet". As he doesn't, the code needs to copy the Information from column A & B in relation to this persons name and paste the information into another sheet in the workbook.
Sub Test3()
Dim x As String
Dim found As Boolean
Range("B2").Select
x = "Internet"
found = False
Do Until IsEmpty(ActiveCell)
If ActiveCell.Value = x Then
found = True
Exit Do
End If
ActiveCell.Offset(1, 0).Select
Loop
If found = False Then
Sheets("Groupings").Activate
Sheets("Groupings").Range("A:B").Select
Selection.Copy
Sheets("Sheet1").Select
Sheets("Sheet1").Range("A:B").PasteSpecial
End If
End Sub
Any help would be greatly appreciated.
Thanks
Paula

Private Sub Test3()
Application.ScreenUpdating = False
Set sh1 = Sheets("Groupings") 'data sheet
Set sh2 = Sheets("Sheet1") 'paste sheet
myVar = sh1.Range("D1")
Lastrow = sh1.Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To Lastrow '2 being the first row to test
If Len(sh1.Range("A" & i)) > 0 Then
Set myFind = Nothing
If WorksheetFunction.CountA(sh1.Range("A" & i, "A" & Lastrow)) > 1 Then
If Len(sh1.Range("A" & i + 1)) = 0 Then
nextrow = sh1.Range("A" & i).End(xlDown).Row - 1
Else
nextrow = nextrow + 1
End If
Set myFind = sh1.Range("B" & i, "B" & nextrow).Find(What:=myVar, LookIn:=xlFormulas, LookAt:=xlWhole)
Else
nextrow = Lastrow
Set myFind = sh1.Range("B" & i, "B" & nextrow).Find(What:=myVar, LookIn:=xlFormulas, LookAt:=xlWhole)
End If
If myFind Is Nothing Then
sh1.Range("A" & i, "B" & nextrow).Copy
sh2.Range("A" & sh2.Range("B" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
End If
Next
End Sub

I don't clearly see the structure of your data, but assuming the original data is in Worksheet Data, I think the following is going to do what you want (edited to search for two conditions).
Private Sub Test3()
Dim lLastRow as Long
Dim a as Integer
Dim i as Integer
Dim sText1 As String
Dim sText2 As String
sText1 = Worksheets("Data").Cells(1, 5).Value 'search text #1, typed in E1
sText2 = Worksheets("Data").Cells(2, 5).Value 'search text #2, typed in E2
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
a = 1
For i = 2 To lLastRow
If (Worksheets("Data").Cells(i, 1).Value <> "") Then
If (Worksheets("Data").Cells(i, 2).Value <> sText1 And Worksheets("Data").Cells(i + 1, 2).Value <> sText1 And Worksheets("Data").Cells(i, 2).Value <> sText2 And Worksheets("Data").Cells(i + 1, 2).Value <> sText2) Then
Worksheets("Groupings").Cells(a, 1).Value = Worksheets("Data").Cells(i, 1).Value
Worksheets("Groupings").Cells(a, 2).Value = Worksheets("Data").Cells(i, 2).Value
Worksheets("Groupings").Cells(a, 3).Value = Worksheets("Data").Cells(i + 1, 2).Value
a = a + 1
End If
End If
Next
End Sub

Related

VBA value range doing strange

So how do i put this i am a vba rookie and i have been trying to make an excel file and the purpose is that it should be an inventory of all items one sheet is for putting items in and other is for giving them away. But that is not the problem, the thing is i wanted to have a page called "databaseinventory" where all products that are taken out are writen down but my value is doing strange. (look at the image)
So this is the input screen and if i type this
this is the output on a different sheet but i don't want it to be 0
I noticed if i change the input and add 3 rows it works but that prevents me of typing more then one product
this is the output that i want to have and i really don't know what is wrong with the code
Sub Btn_Clickweggegeven()
Dim x As Long
Dim Givenaway As Worksheet
Dim Inventory As Worksheet
Dim productn As String
Dim erow As Long
Dim rng As Range
Dim rownumber As Long
Dim row As Long
Dim wsData As Worksheet
Dim wsIn As Worksheet
Dim nextRow As Long
Dim BtnText As String
Dim BtnNum As Long
Dim strName As String
x = 2
Do While Cells(x, 1) <> ""
' go through each item on list
productn = Cells(x, 1)
' if item is not new then add quanity to total Inventory
With Worksheets("Inventory").Range("A:A")
Set rng = .Find(What:=productn, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'if item is new add item to the bottom of Inventory list
If rng Is Nothing Then
erow = Worksheets("Inventory").Cells(1, 1).CurrentRegion.Rows.Count + 1
Worksheets("Inventory").Cells(erow, 1) = Worksheets("Givenaway").Cells(x, 1)
Worksheets("Inventory").Cells(erow, 2) = Worksheets("Givenaway").Cells(x, 2)
Worksheets("Inventory").Cells(erow, 3) = Worksheets("Givenaway").Cells(x, 3)
Worksheets("Inventory").Cells(erow, 4) = Worksheets("Givenaway").Cells(x, 4)
GoTo ende
Else
rownumber = rng.row
End If
End With
Worksheets("Inventory").Cells(rownumber, 2).Value = Worksheets("Inventory").Cells(rownumber, 2).Value _
- Worksheets("Givenaway").Cells(x, 2).Value
Worksheets("Inventory").Cells(rownumber, 4).Value = Worksheets("Inventory").Cells(rownumber, 4).Value _
+ Worksheets("Givenaway").Cells(x, 2).Value
ende:
x = x + 1
Loop
'after complete delete items from Givenaway list
Worksheets("Givenaway").Select
row = 2
Do While Cells(row, 1) <> ""
Range(Cells(row, 1), Cells(row, 3)).Select
Selection.Delete
Loop
Set wsIn = Worksheets("Givenaway")
Set wsData = Worksheets("Databaseinventory")
With wsData
nextRow = .Cells(.Rows.Count, "A") _
.End(xlUp).Offset(1, 0).row
End With
With wsData
With .Cells(nextRow, 1)
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, 2).Value = productn
.Cells(nextRow, 3).Value = Worksheets("Databaseinventory").Cells(rownumber, 3).Value _
+ Worksheets("Givenaway").Cells(x, 2).Value
End With
End Sub
This code is deleting the value
Worksheets("Givenaway").Select
row = 2
Do While Cells(row, 1) <> ""
Range(Cells(row, 1), Cells(row, 3)).Select
Selection.Delete
Loop
before this line copies it to Databaseinventory
Cells(nextRow, 3).Value = Worksheets("Databaseinventory").Cells(rownumber, 3).Value _
+ Worksheets("Givenaway").Cells(x, 2).Value
It appears to work if you have 3 rows is because on exit from the Do While Cells(x, 1) <> "" loop the value of x will be 3. After deleting the first record then Worksheets("Givenaway").Cells(x, 2).Value will be the value for the third record.
The database update routine also need to be within the loop
Option Explicit
Sub Btn_Clickweggegeven()
Dim wb As Workbook, rng As Range
Dim wsInv As Worksheet, wsGiven As Worksheet, wsData As Worksheet
Dim iRow As Long, iDataRow As Long, iInvRow As Long
Dim sProduct As String, nValue As Single
Set wb = ThisWorkbook
Set wsGiven = wb.Sheets("GivenAway")
Set wsInv = wb.Sheets("Inventory")
Set wsData = wb.Sheets("Databaseinventory")
iDataRow = wsData.Cells(Rows.Count, 1).End(xlUp).row
iRow = 2
With wsGiven
Do While .Cells(iRow, 1) <> ""
sProduct = .Cells(iRow, 1)
nValue = .Cells(iRow, 2)
' if item is not new then add quanity to total Inventory
With wsInv.Range("A:A")
Set rng = .Find(What:=sProduct, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With
If rng Is Nothing Then
iInvRow = wsInv.Cells(Rows.Count, 1).End(xlUp).row + 1
wsInv.Cells(iInvRow, 1).Resize(1, 4).Value = .Cells(iRow, 1).Resize(1, 4).Value
Else
iInvRow = rng.row
wsInv.Cells(iInvRow, 2).Value = wsInv.Cells(iInvRow, 2).Value - nValue
wsInv.Cells(iInvRow, 4).Value = wsInv.Cells(iInvRow, 4).Value + nValue
End If
' write to database
iDataRow = iDataRow + 1
With wsData.Cells(iDataRow, 1)
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
.Offset(0, 1) = sProduct ' col B
.Offset(0, 2) = wsInv.Cells(iInvRow, 3).Value + nValue ' col C ??
End With
iRow = iRow + 1
Loop
End With
'delete from GivenAway
wsGiven.Range("A2").Resize(iRow, 3).Delete
MsgBox iRow - 2 & " records processed", vbInformation
End Sub

Avoid copying buttons in range

i have a macro where i copy paste a range, which also has buttons in there.
Now i dont want the buttons to get copied. How can i do that?
I copy the whole table and insert it again at A32.
lrow = .Cells(Rows.Count, 1).End(xlUp).row
Do While counter = 0
For i = 32 To lrow
If .Cells(i, 1).Value = "Review Participants" And counter = 1 Then
lastrev = lrowrev
lrowrev = i - 1 'row where the second last review starts
aboveR = lrowrev - lastrev
Exit For
ElseIf .Cells(i, 1).Value = "Review Participants" And counter <> 1 Then
counter = counter + 1
lrowrev = i
lcol = 11 'hardcode last col ~~ Alt: 'lcol = .Cells(i + 1, .Columns.Count).End(xlToLeft).Column 'last meeting of the review is our reference for lastcol
ElseIf counter = 1 And i = lrow Then
lrowrev = i + 2
aboveR = (i + 2) - 32
Exit For
End If
Next
Loop
lastcolumn = Split(Cells(, lcol).Address, "$")(1)
Set rngtocopy = .Range("A" & 32 & ":" & lastcolumn & lrowrev)
Debug.Print rngtocopy.Address
'aboveR = .Range("A" & 32 & ":" & lastcolumn & lrowrev - 1).Rows.Count ' amount of rows copied
Set rngins = .Range("A32").EntireRow
Debug.Print rngins.EntireRow.Resize(aboveR + 2).Address
rngins.EntireRow.Resize(aboveR + 2).Insert xlShiftDown 'insert the amount of rows, we copied
'Range("A" & lrow).Offset(5).EntireRow.Hidden = False
Set rngins = .Range("A32")
Debug.Print rngins.Address
rngtocopy.Copy
rngins.PasteSpecial Paste:=xlPasteAll
Try this code, please:
Sub copyRangeNoButt()
Dim sh As Worksheet, rng As Range, arrRng As Variant
Set sh = ActiveSheet
Set rng = sh.Range("D2:E10"): rng.Copy
arrRng = rng.value
With sh.Range("H2").Resize(UBound(arrRng, 1), UBound(arrRng, 2))
.value = arrRng
.PasteSpecial xlPasteFormats'comment this line if format is not needed. It takes much more time than all the rest of the code, in case of a big range...
End With
End Sub
Of course, you must adapt the code to use your range to be copied definition and the cell where to be pasted (even if in another worksheet).
Now i dont want the buttons to get copied. How can i do that?
You can also use PasteSpecial. You can take advantage of XlPasteType enumeration to copy and paste only relevant part. For example, here is a one liner in case you want to paste
A. Everything except the image
rng.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
B. Only Values
rng.PasteSpecial Paste:=xlPasteValues
In action

How to unmerge rows and not column

I have a table which contains merged cells both column and rows as shown in attached picture. I want to unmerge "Only" rows while leaving columns merged. Consider the following snippet of table. In the image attached "Contract
For y = 1 To lRow
p = 1
c = y
d = 1
z = lRow + y
t = Cells(y, 1).Value
For x = 1 To t
Cells(z, p).Value = Cells(c, d).Value
Cells(c, d).Select
' Debug.Print
Selection.End(xlToRight).Select
c = ActiveCell.Row
d = ActiveCell.Column
p = p + 1
Next
Next
Sub ColorMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells And c.MergeArea.Rows.Count >= 2 Then
c.Interior.ColorIndex = 28
With c.MergeArea.Rows
.UnMerge
' .Formula = c.Formula
End With
'
'startcolumn = ActiveCell.Column
'endcolumn = Selection.Columns.Count + startcolumn - 1
'startrow = ActiveCell.Row
'endrow = Selection.Rows.Count + startrow - 1
End If
Next
End Sub
Based on your snapshot of requirements , I have wrote a very simple code which shall appear to be crude but I have kept it this way so that you can adjust its various elements as per your actual data. Sample data taken by me and results obtained are shown in the snapshot pasted below, which is followed by code.
Sub Merge_unmerge()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim LastRow As Long
Dim LastCol As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
With ws
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
Set rng = ws.Range("A1:D" & LastRow)
For Each cell In rng
cell.UnMerge
Next cell
For i = 2 To LastRow
If Range("A" & i) = "" Then
Range("A" & i).Value = Range("A" & i - 1).Value
End If
Next i
For i = 2 To LastRow
If Range("D" & i) = "" Then
Range("D" & i).Value = Range("D" & i - 1).Value
End If
Next i
For i = 1 To LastRow Step 2
Range("B" & i & ":C" & i).Merge
Range("B" & i & ":C" & i).HorizontalAlignment = xlCenter
Next i
End Sub
Never mind. I solved for the issue at hand. Posting if it helps others.
Sub ColorMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells And c.MergeArea.Rows.Count >= 2 Then
c.Interior.ColorIndex = 28
startcolumn = c.Column
endcolumn = c.MergeArea.Columns.Count + startcolumn - 1
startrow = c.Row
endrow = c.MergeArea.Rows.Count + startrow - 1
With c.MergeArea.Rows
.UnMerge
.Formula = c.Formula
End With
For J = startrow To endrow
Application.DisplayAlerts = False
Range(Cells(J, startcolumn), Cells(J, endcolumn)).Merge
Application.DisplayAlerts = True
Next
End If
Next
End Sub

If cell value same with upper cell value

I tried to make macro for my daily job, but i cannot use IF as formula due to so many item in my excel file, so solution is to convert formula to VBA code.
I need help to convert if formula to VBA code in excel as below:
=IF(J2<>J1,AD2-X2,AE1-X2).
Here is an answer to your question. However, it is limited to only work with OP information. Also, if the calculations are taking too long then, you should try setting your calculation to Manual (Formulas->Calculation Options->Manual).
Option Explicit
Public Sub RunIF()
Dim vntOut As Variant
Dim rngSame As Range
With ActiveSheet
Set rngSave = .Range("X2")
If (LCase(Trim(.Range("J2").Value)) <> LCase(Trim(.Range("J1").Value))) Then
vntOut = .Range("AD2").Value - rngSave.Value
Else
vntOut = .Range("AE1").Value - rngSave.Value
End If
.Range("AE2").value = vntOut
Set rngSave = Nothing
End With
End Sub
And here is your code converted to use Column J:
Private Sub CommandButton12_Click()
Dim x As Long
Dim LastRow As Long
Dim i as long
With Sheets("Shipping Schedule")
LastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
For i = 2 to LastRow
set r = .Range("J" & I)
'For Each r In .Range("J2:J" & LastRow)
If LCase(Trim(r.Value)) <> LCase(Trim(r.Offset(-1, 0).Value)) Then
'ae2 = "AD2" - "x2"
r.Offset(0, 21).Value = r.Offset(0, 20).Value - r.Offset(0, 14).Value
Else
'ae2 = "AE1" - "x2"
r.Offset(0, 21).Value = r.Offset(-1, 21).Value - r.Offset(0, 14).Value
End If
set r = nothing
Next i
End With
End Sub
However, you should increment with I instead of for each as the cells are dependent on the previous row and excel may not loop through the range like you would prefer.
Excel Formula to VBA: Fill Column
Sub FillColumn()
Const cCol As Variant = "J" ' Last-Row-Column Letter/Number
Const cCol1 As Variant = "AD"
Const cCol2 As Variant = "X"
Const cCol3 As Variant = "AE"
Const cFirstR As Long = 1 ' First Row
Dim rng As Range ' Last Used Cell in Last-Row-Column
Dim i As Long ' Row Counter
Set rng = Columns(cCol).Find("*", , xlFormulas, , xlByColumns, xlPrevious)
If rng Is Nothing Then Exit Sub
For i = cFirstR To rng.Row - 1
If Cells(i + 1, cCol) <> Cells(i, cCol) Then
Cells(i + 1, cCol3) = Cells(i + 1, cCol1) - Cells(i + 1, cCol2)
Else
Cells(i + 1, cCol3) = Cells(i, cCol3) - Cells(i + 1, cCol2)
End If
Next
End Sub
Private Sub CommandButton12_Click()
Dim x As Long
Dim LastRow As Long
Sheets("Shipping Schedule").Select
With Sheets("Shipping Schedule")
LastRow = .Cells(.Rows.Count, "N").End(xlUp).Row
For Each r In .Range("N2:N" & LastRow)
If r.Value <> "" Then
r.Offset(0, 19).Value = ………………………………….
End if
Next r
End With
End Sub

How to get the sum of two adjacent columns into one merged cell (VBA)?

I am creating a summary macro and I need to add up all the values of column C and D into the merged cell in E. In the image attached the sums are already placed to show the result I want. I already have code to merge the cells in column E based on the names in A. IE Sum up all overdue and critical for bob and place in merged column, then nick. Here is what I have I just need help getting the sum:
Sub MergeSameCell()
Dim Rng As Range, xCell As Range
Dim xRows As Integer
Set WorkRng = ThisWorkbook.Worksheets("Summary").Range("A:A")
lastRow = ActiveSheet.Columns("A").Cells.Find("*", SearchOrder:=xlByRows,
LookIn:=xlValues, SearchDirection:=xlPrevious).Row
xRows = lastRow
For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
WorkRng.Parent.Range(Rng.Cells(i, 5), Rng.Cells(j - 1, 5)).Merge
i = j - 1
Next
Next
End Sub
The below uses your enclosed data specifically and assumes the data has already been sorted by column A and the cells in column E are already merged.
Public Sub GroupSum()
Dim i0 As Long, i1 As Long, strName As String
With ActiveSheet
For i0 = 2 To .UsedRange.Rows.Count
If Not .Cells(i0, 1).Value = strName Then
strName = .Cells(i0, 1)
i1 = i0
End If
.Cells(i1, 5).Value = .Cells(i0, 3).Value + .Cells(i0, 4).Value + .Cells(i1, 5).Value
Next i0
End With
End Sub
I will leave the alignment formatting of the merged cells to you.
Option Explicit
Sub MergeSameCell()
Dim clientRng As Range
Dim lastRow As Long, lastClientRow As Long
With ThisWorkbook.Worksheets("Summary")
.Columns(5).UnMerge
Set clientRng = .Range("A2")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Do
lastClientRow = .Columns(1).Find(what:=clientRng.Value, after:=clientRng, _
lookat:=xlWhole, SearchDirection:=xlPrevious).Row
With clientRng.Offset(0, 4)
.Resize(lastClientRow - clientRng.Row + 1, 1).Merge
.Formula = "=sumifs(c:c, a:a, " & Chr(34) & clientRng.Value2 & Chr(34) & ")+" & _
"sumifs(d:d, a:a, " & Chr(34) & clientRng.Value2 & Chr(34) & ")"
'optionally revert the formulas to their returned value
'value = .value2
End With
Set clientRng = clientRng.Offset(lastClientRow - clientRng.Row + 1, 0)
Loop While clientRng.Row <= lastRow
End With
End Sub
This removes a couple of loops:
Sub MergeSameCell()
With ThisWorkbook.Worksheets("Summary")
Dim i as Long
For i = 2 To .Rows.Count
If .Cells(i, 1) = "" Then Exit Sub
Dim x As Long
x = .Evaluate("MATCH(TRUE," & .Cells(i, 1).Address & "<>" & .Range(.Cells(i, 1), .Cells(.Rows.Count, 1)).Address & ",0) - 2 + " & i)
.Cells(i, 5).Value = Application.Sum(.Range(.Cells(i, 3), .Cells(x, 4)))
.Range(.Cells(i, 5), .Cells(x, 5)).Merge
i = x
Next i
End With
End Sub

Resources