How to do multiple select with ActiveCell - excel

I'm trying to make multiple selections from Sheet2. The value is from the same column but different rows (thinking if using ActiveCell.Offset(1,0) will be feasible).
My code takes the value from an ActiveCell select and runs a macro compares it to another sheet (Sheet10) with some information to copy and paste in a target sheet (Sheet5).
The following is the code that I have right now.
a = Sheet10.Cells(Rows.Count, 1).End(xlUp).Row
c = Sheet2.Cells(Rows.Count, 5).End(xlUp).Row
For Each cell In Range(ActiveCell, ActiveCell.Offset(1, 0))
For i = 2 To a 'from Row 1 to the last row of "DMP"
Debug.Print ("i = " & i)
If cell.Value = Sheet10.Cells(i, 1).Value Then 'if selected cell matches (i,1) of "Sheet10 (DMP)"
Debug.Print ("ActiveCell =" & ActiveCell.Value)
For k = 1 To 20 'from Column 1 to Column 20
Debug.Print ("k = " & k)
For r = 1 To c 'from Row 1 to the last row of "Sheet 2(LightOn SKU)"
Debug.Print ("r = " & r)
If Sheet10.Cells(i, k).Value = Sheet2.Cells(r, 4).Value Then 'if value of (i,k) of "Sheet10 (DMP)" = (r,4) of "Sheet2 (LightOn SKU)"
Sheet2.Range("A" & r & ":G" & r).Copy
Sheet5.Activate
b = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
Sheet5.Cells(b + 1, 1).Select
ActiveSheet.Paste
Range("A" & r & ":L" & r).Borders.Color = vbBlack
End If
Next
Next
End If
Next
Next
Right now, it's running on an endless loop.

Still Unclear
Sub ACCopy2()
Dim a As Long
Dim c As Long
Dim r As Long
Dim i As Long
Dim k As Integer
Dim b As Long
a = Sheet10.Cells(Rows.Count, 1).End(xlUp).Row
c = Sheet2.Cells(Rows.Count, 5).End(xlUp).Row
For r = 1 To c ' from Row 1 to the last row of "Sheet 2(LightOn SKU)"
Debug.Print ("r = " & r)
For i = 2 To a ' from Row 1 to the last row of "DMP"
Debug.Print ("i = " & i)
' if selected cell matches (i,1) of "Sheet10 (DMP)"
If Sheet2.Cells(r, 1).Value = Sheet10.Cells(i, 1).Value Then
Debug.Print ("Sheet2 =" & Sheet2.Cells(r, 1).Value)
For k = 1 To 20 ' from Column 1 to Column 20
Debug.Print ("k = " & k)
' if value of (i,k) of "Sheet10 (DMP)" = (r,4) of
' "Sheet2 (LightOn SKU)"
If Sheet10.Cells(i, k).Value = Sheet2.Cells(r, 4).Value Then
With Sheet5
b = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
Sheet2.Range("A" & r & ":G" & r).Copy .Cells(b + 1, 1)
.Range("A" & r & ":L" & r).Borders.Color = vbBlack
End With
End If
Next
End If
Next
Next
End Sub

Related

VBA Excel Insert a row if condition

I have an Excel sheet (doc1) with 4 columns. In "A" I have people names. In "B","C" and "D", I have informations on the CV of each of these people. I would like to extract in another sheet (doc2) these informations in a specific format: For each CV information, I would like to insert a row with the name of the person in "A" and one information about his CV in "B". Basically if I have 3 informations about a person in doc1 (In B,C and D), I want to have 3 rows : In A1, A2 and A3 the name of the person, and in B1, B2 and B3 the person's infos.
I have a macro which does the exact opposite, it is basically doing a Vlookup which throws multiple results. Any idea on how to turn this around? Thanks!
Option Explicit
Sub GO()
Dim J As Long
Dim I As Integer
Dim K As Long
Dim Indice As Long
Dim Tablo
Dim Nb As Integer
Application.ScreenUpdating = False
ReDim Tablo(1 To Range("A" & Rows.Count).End(xlUp).Row - 2, 1 To 2)
Tablo(1, 1) = Range("A2")
Tablo(1, 2) = Range("B2")
Nb = 1
For J = 3 To Range("A" & Rows.Count).End(xlUp).Row
For K = 1 To UBound(Tablo)
If Range("A" & J) = Tablo(K, 1) Then
For I = 1 To UBound(Tablo, 2)
If Tablo(K, I) = "" Then
Tablo(K, I) = Range("B" & J)
Exit For
End If
Next I
If I > UBound(Tablo, 2) Then
ReDim Preserve Tablo(1 To UBound(Tablo), 1 To UBound(Tablo, 2) + 1)
Tablo(K, UBound(Tablo, 2)) = Range("B" & J)
End If
Exit For
ElseIf Tablo(K, 1) = "" Then
Nb = Nb + 1
Tablo(K, 1) = Range("A" & J)
Tablo(K, 2) = Range("B" & J)
Exit For
End If
Next K
Next J
With Sheets("doc2")
.Cells.ClearContents
.Range("A2").Resize(Nb, UBound(Tablo, 2)) = Tablo
.Range("A1") = "Name"
.Range("B1") = "C.V info 1"
.Range("B1").AutoFill .Range("B1").Resize(, UBound(Tablo, 2) - 1), xlFillSeries
End With
End Sub
try somethihng like this:
Function NeverCallAFunctionGO:
dim doc1 as worksheet, doc2 as worksheet
dim lRow as long
'set your doc1 and doc2 sheets
lRow = 1
For i = 1 to doc1.range("A1").end(xldown).row
doc2.range("A" & lRow).value = doc1.range("A" & i).value
doc2.range("B" & lRow).value = doc1.range("B" & i).value
doc2.range("B" & lRow+1).value = doc1.range("C" & i).value
doc2.rangE("B" & lRow+2).value = doc1.rangE("D" & i).value
lRow = lRow + 3
Next i

To Get only one raw of result for a particular Range

Following code is suggested by a helpful user, this works well to Calculate "From", "To", "MAX" etc values of a range. But this code gives results in every row of a range. I want to get the results in only first row of each row. Please help with this.
Sub trial()
Dim lastrow As Long
Dim destSht As Worksheet
Dim i As Long, j As Long
Set destSht = Worksheets("Final")
With Worksheets("Source")
lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 2 To lastrow + 1 'loop whole range (column C)
If .Cells(i, "C") <> "" Then 'If column C is not empty then
For j = i To lastrow + 1 'Loop "group" range to find next empty cell. Start from current loop i to last row and add one row to get to next empty cell.
If .Cells(j, "C") = "" Then 'When next empty cell is found (i.e. end of small group range) then apply formulas
.Cells(i, "E").Value = .Cells(i, "B").Value 'From
.Cells(i, "F").Value = .Cells(j - 1, "B").Value 'To
.Cells(i, "G").Formula = "=MAX(C" & i & ":C" & j - 1 & ")" 'MAX
.Cells(i, "H").Formula = "=MIN(C" & i & ":C" & j - 1 & ")" 'MIN
.Cells(i, "I").Formula = "=AVERAGE(C" & i & ":C" & j - 1 & ")" 'AVG
Exit For
End If
Next j
End If
Next I
End With
End Sub
This Code gives following result
Desired Result
Try changing this line:
If .Cells(i, "C") <> "" Then 'If column C is not empty then
To this line:
If .Cells(i, "C") <> "" AND .Cells(i-1, "C") = "" Then 'If column C is not empty AND the column C above is empty then

I have written a piece of code that does reconciliation: The first part checks between columns:

I have written a piece of code that does reconciliation:
The first part checks between columns.
Works absolutely fine on upto 100k Rows, then simply freezes on anything bigger. Is the an optimal way to write this? Should I be using a scripting dictionary for the reconciliation too? Ive been off VBA for a while now and I am pretty rusty! Thanks for reading and helping.
Sub AutoRecon()
Worksheets("Main_Recon").Select
Dim i As Long, _
LRa As Long, _
LRb As Long, _
rowx As Long
LRa = Range("A" & Rows.Count).End(xlUp).Row
LRb = Range("G" & Rows.Count).End(xlUp).Row
rowx = 2
Application.ScreenUpdating = False
For i = 2 To LRa
If Range("A" & i).Errors.Item(xlNumberAsText).Value = True Then
Range("A" & i).Value = "N" & Range("A" & i).Value
rowx = rowx + 1
End If
Next i
rowx = 2
For i = 2 To LRb
If Range("G" & i).Errors.Item(xlNumberAsText).Value = True Then
Range("G" & i).Value = "N" & Range("G" & i).Value
rowx = rowx + 1
End If
Next i
rowx = 2
For i = 2 To LRa
If IsError(Application.Match(Range("A" & i).Value, Range("G2:G" & LRb), 0)) Then
Range("O" & rowx).Value = Range("A" & i).Value
rowx = rowx + 1
End If
Next i
rowx = 2
For i = 2 To LRb
If IsError(Application.Match(Range("G" & i).Value, Range("A2:A" & LRa), 0)) Then
Range("S" & rowx).Value = Range("G" & i).Value
rowx = rowx + 1
End If
Next i
Application.ScreenUpdating = True
End Sub
This takes too long.
The issue is that you run the loop 4 times, but you can combine 2 loops.
You can gain some speed in the process using arrays to read/write. Every read/write action to a cell needs a lot of time. So the idea is to read all data cells into an array DataA at once (only 1 read action) then process the data in the array and then write it back to the cells at once (only 1 write action). So if you have 100 rows you save 99 read/write actions.
So you would end up with something like below. Note this is untested, so backup before running this.
Option Explicit
Public Sub AutoRecon()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Main_Recon")
Application.ScreenUpdating = False
'find last rows of columns
Dim LastRowA As Long
LastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim LastRowG As Long
LastRowG = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
'read data into array
Dim DataA() As Variant 'read data from column A into array
DataA = ws.Range("A1", "A" & LastRowA).Value
Dim DataG() As Variant 'read data from column G into array
DataG = ws.Range("G1", "G" & LastRowG).Value
Dim iRow As Long
For iRow = 2 To Application.Max(LastRowA, LastRowG) 'combine loop to the max of both columns
If iRow <= LastRowA Then 'run only until max of column A
If ws.Cells(iRow, "A").Errors.Item(xlNumberAsText).Value = True Then
DataA(iRow, 1) = "N" & DataA(iRow, 1)
End If
End If
If iRow <= LastRowG Then 'run only until max of column G
If ws.Cells(iRow, "G").Errors.Item(xlNumberAsText).Value = True Then
DataG(iRow, 1) = "N" & DataG(iRow, 1)
End If
End If
Next iRow
'write array back to sheet
ws.Range("A1", "A" & LastRowA).Value = DataA
ws.Range("G1", "G" & LastRowG).Value = DataG
'read data into array
Dim DataO() As Variant 'read data from column O into array (max size = column A)
DataO = ws.Range("O1", "O" & LastRowA).Value
Dim DataS() As Variant 'read data from column G into array (max size = column G)
DataS = ws.Range("S1", "S" & LastRowG).Value
Dim oRow As Long, sRow As Long
oRow = 2 'output row start
sRow = 2
For iRow = 2 To Application.Max(LastRowA, LastRowG) 'combine loop to the max of both columns
If iRow <= LastRowA Then
If IsError(Application.Match(DataA(iRow, 1), DataG, 0)) Then
DataO(oRow, 1) = DataA(iRow, 1)
oRow = oRow + 1
End If
End If
If iRow <= LastRowG Then
If IsError(Application.Match(DataG(iRow, 1), DataA, 0)) Then
DataS(sRow, 1) = DataG(iRow, 1)
sRow = sRow + 1
End If
End If
Next iRow
'write array back to sheet
ws.Range("O1", "O" & LastRowA).Value = DataO
ws.Range("S1", "S" & LastRowG).Value = DataS
Application.ScreenUpdating = True
End Sub

Excel VBA Paste error when applying style to cell

I'm seeking some assistance. I have a code that does what I need and works pretty fine, but I want to make it do some more, and thats when it breaks.
Here is the code, a bit messy I know:
Sub AgainstAbstain()
Application.ScreenUpdating = False
'Stating variables
Dim Abstain As String
Abstain = "Abstain"
Dim Against As String
Against = "Against"
Dim C11 As Variant
'Enter amount of votable items
Dim e As Byte 'number of agenda items
e = InputBox("Number of votable items in Agenda?")
'Create Necessary sheets
On Error Resume Next
Sheets("Abstain").Delete
'Sheets("Against").Delete
On Error GoTo 0
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
'ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveWorkbook.Sheets(2).Name = "Abstain"
'ActiveWorkbook.Sheets(3).Name = "Against"
'Change zoom level of sheets
Sheets(2).Activate
ActiveWindow.Zoom = 85
'Sheets(3).Activate
'ActiveWindow.Zoom = 85
Sheets(1).Activate
'For better copying of cells
Cells.WrapText = False
'To count spaces
Dim j As Integer
j = 1
Dim k As Integer
k = 1
Dim c As Integer
c = 3 '
'Main filter and copy
For i = 1 To e
Worksheets(1).Cells(11, c).Select
C11 = ActiveCell.Value
'Range("A11:C11").Select
Range(Cells(11, 1), Cells(11, c)).Select
Selection.AutoFilter
ActiveSheet.Range("C:C").AutoFilter Field:=c, Criteria1:="ABSTAIN"
'Amount of items visible after filter
Dim x As Integer
x = Application.Subtotal(3, Columns("A")) - 19
'MsgBox x
If x > 0 Then
ActiveSheet.AutoFilter.Range.Offset(1).Copy
Sheets("ABSTAIN").Activate
' Range("A" & j).Select
' Range("A" & j).Font.Bold = True
' Range("A" & j).Font.Underline = True
Range("A" & j).Value = C11 & ") " & Abstain
j = j + 2
' Range("A" & j).Select
Range("A" & j).Value = "Beneficial owner:"
'Range("A" & j).Font.Bold = True
Range("B" & j).Value = "Number of shares:"
'Range("A" & j).Font.Bold = True
j = j + 1
Sheets(2).Range("A" & j).PasteSpecial
' Range("A" & j).Select
' ActiveSheet.Paste
j = j + x
Range("A" & j).Value = "Sum"
Range("A" & j).Font.Bold = True
Range("A" & j).Interior.Color = RGB(255, 204, 153)
Range("B" & j).Font.Bold = True
Range("B" & j).Interior.Color = RGB(255, 204, 153)
j = j + 3
Columns(3).EntireColumn.Delete
Err.Clear
Sheets(1).Activate
Worksheets(1).Columns(c).Hidden = True
c = c + 1
Cells.AutoFilter
Else: Cells.AutoFilter
Worksheets(1).Columns(c).Hidden = True
c = c + 1
End If
Next i
Cells.EntireColumn.Hidden = False
c = 3
For i = 1 To e
Worksheets(1).Cells(11, c).Select
C11 = ActiveCell.Value
'Range("A11:C11").Select
Range(Cells(11, 1), Cells(11, c)).Select
Selection.AutoFilter
ActiveSheet.Range("C:C").AutoFilter Field:=c, Criteria1:="AGAINST"
'Amount of items visible after filter
Dim y As Integer
y = Application.Subtotal(3, Columns("A")) - 19
'MsgBox y
If y > 0 Then
ActiveSheet.AutoFilter.Range.Offset(1).Copy
Sheets("Abstain").Activate
' Range("A" & j).Select
Range("A" & j).Value = C11 & ") " & Abstain
j = j + 2
' Range("A" & j).Select
Range("A" & j).Value = "Beneficial owner:"
Range("B" & j).Value = "Number of shares:"
j = j + 1
Sheets(2).Range("A" & j).PasteSpecial
' Range("A" & j).Select
' ActiveSheet.Paste
j = j + y
Range("A" & j).Value = "Sum"
Range("A" & j).Font.Bold = True
Range("A" & j).Interior.Color = RGB(255, 153, 204)
Range("B" & j).Font.Bold = True
Range("B" & j).Interior.Color = RGB(255, 153, 204)
j = j + 3
Columns(3).EntireColumn.Delete
Err.Clear
Sheets(1).Activate
Worksheets(1).Columns(c).Hidden = True
c = c + 1
Cells.AutoFilter
Else: Cells.AutoFilter
Worksheets(1).Columns(c).Hidden = True
c = c + 1
End If
'If y > 0 Then
'ActiveSheet.AutoFilter.Range.Offset(1).Copy
' Sheets("AGAINST").Activate
' Range("A" & k).Select
' Range("A" & k).Value = C11 & ") " & Against
' k = k + 2
' Range("A" & k).Select
' Range("A" & k).Value = "Beneficial owner:"
' k = k + 1
' Range("A" & k).Select
' ActiveSheet.Paste
' k = k + y
' Range("A" & k).Value = "Sum"
' k = k + 3
' Columns(3).EntireColumn.Delete
' Err.Clear
' Sheets(1).Activate
' Cells.AutoFilter
' 'Columns(3).EntireColumn.Delete
' Worksheets(1).Columns(c).Hidden = True
' c = c + 1
'Else: Cells.AutoFilter
' 'Columns(3).EntireColumn.Delete
' Worksheets(1).Columns(c).Hidden = True
' c = c + 1
'End If
Next i
Sheets(2).Activate
For Each NumRange In Columns("B").SpecialCells(xlConstants, xlNumbers).Areas
SumAddr = NumRange.Address(False, False)
NumRange.Offset(NumRange.Count, 0).Resize(1, 1).Formula = "=SUM(" & SumAddr & ")"
c = NumRange.Count
Next NumRange
NoData:
'Sheets(2).Select
Columns("A:B").AutoFit
Sheets(1).Activate
Cells.EntireColumn.Hidden = False
Application.ScreenUpdating = True
End Sub
It filters and moves data just fine. But when i try to activate this part
' Range("A" & j).Font.Bold = True
' Range("A" & j).Font.Underline = True
It gives me this error
Run-time error '1004':
PasteSpecial method of Range class failed. In fact, if I try to activate any style change before the paste i get this error.
And highlights this area
Sheets(2).Range("A" & j).PasteSpecial
I just don't get.
After the .Copy method you need to immediately paste the results. Doing anything else will empty the copy buffer, so this will work:
ActiveSheet.Range("A1").Copy
ActiveSheet.Range("A2").PasteSpecial
ActiveSheet.Range("A1").Font.Size = 10
But this won't
ActiveSheet.Range("A1").Copy
ActiveSheet.Range("A1").Font.Size = 10
ActiveSheet.Range("A2").PasteSpecial

Userform contains Textbox and Checkbox intput to worksheet

The user can enter up to 10 members at once.
Column A will be "Team Number"
Column B will be "Number of Member"
Column C will be "Member Name"
Column D will be "Month Available"
Column E will be "Number of Family Members Coming"
Column F will be "Family Members"
I have trouble trying to input the userform values to the worksheet.
'inputValue
Dim RowCount As Long
Dim rStart As Long
Dim rFirstEnd As Long
Dim rLastEnd As Long
RowCount = Worksheets("Sheet1").Range("A1").CurrentRegion.Rows.Count
rMemberEnd = CLng(txtNoMember.Value)
rMonthEnd = CLng(txtNoMember.Value)
rFamilyMemberEnd = CLng(txtNoFamilyMemberValue)
For rStart = 1 To rMemberEnd
With Worksheets(“Sheet1").Range("A1")
.Offset(RowCount + rStart, 0).Value = txtTeamNo.Text
.Offset(RowCount + rStart , 1).Value = txtNoMember.Text
.Offset(RowCount + rStart , 2).Value = Controls("txtMemberName” & Format(rStart, "00")).Value
For rStart = 1 To rMonthEnd
With Worksheets(“Sheet1").Range("A1")
If Controls ("chkMonth” & Format(rStart, "00")).Value = True Then
.Offset(RowCount + rStart , 3).Value = CLng(Right$(Controls("chkMonth” & Format(rStart, "00")).Name, 2))
.Offset(RowCount + rStart , 4).Value = txtNoFamilyMember.Text
For rStart = 1 To rFamilyMemberEnd
With Worksheets(“Sheet1").Range("A1")
.Offset(RowCount + rStart , 5).Value = Controls("txtFamilyMember" & Format(rStart, "00")).Text
End With
End If
End With
End With
Next
This is the input to the worksheet.
This is what the UserForm looks like
I've built a UserForm similar to yours and named the controls on it accordingly
now, double clicked the command button and used this code
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Dim members As Long
members = CLng(txtNoMember.Value)
Dim family As Long
family = CLng(txtNoFamilyMember.Value)
Dim months As Long
Dim i As Long
For i = 1 To 12
If Controls("chkMonth" & Format(i, "00")).Value = True Then
months = months + 1
End If
Next i
Dim total As Long
total = members * months * family
Dim j As Long, k As Long, m As Long, n As Long
For i = 1 To members
For j = 1 To total / members
ws.Range("A" & ws.Range("A" & Rows.Count).End(xlUp).Row + 1) = CLng(txtTeamNo)
ws.Range("B" & ws.Range("B" & Rows.Count).End(xlUp).Row + 1) = members
ws.Range("C" & ws.Range("C" & Rows.Count).End(xlUp).Row + 1) = Controls("txtMemberName" & Format(i, "00")).Value
ws.Range("E" & ws.Range("E" & Rows.Count).End(xlUp).Row + 1) = family
Next j
For j = 1 To months
For m = 1 To family
If Len(Controls("txtFamilyMember" & Format(m, "00")).Text) <> vbNullString Then
ws.Range("F" & ws.Range("F" & Rows.Count).End(xlUp).Row + 1) = Controls("txtFamilyMember" & Format(m, "00")).Text
End If
Next m
Next j
For j = 1 To 12
If Controls("chkMonth" & Format(j, "00")).Value = True Then
ws.Range("D" & ws.Range("D" & Rows.Count).End(xlUp).Row + 1) = CLng(Right$(Controls("chkMonth" & Format(j, "00")).Name, 2))
ws.Range("D" & ws.Range("D" & Rows.Count).End(xlUp).Row).Resize(family, 1).Formula = ws.Range("D" & ws.Range("D" & Rows.Count).End(xlUp).Row).Formula
End If
Next j
Next i
Me.Hide
End Sub
which produced
Me.Hide hides the form instead of unloading it. Therefore the data on the form should still be accessible from the Module's code.
In your mode you load the form like this
UserForm1.Show
and then when you're done fetching data from it (again, that's in the Module no under the button's event) you unload it
Unload UserForm1

Resources