VBA Looping Through Multiple Worksheets - vba

I am working on building code which can loop through a column (B5:B) on multiple worksheets to find matching values. If the Value on one worksheet's column (B5:B) is equal to a worksheet name, then the worksheet name is placed on the adjacent column (C5:C) to where the value was found. I am not a programmer, but I've been learning VBA to make this happen. So far I have tried unsuccessfully to use the For Next Loop (starting with the 3rd sheet), the For Each ws in Thisworkbook.sheets method. But I don't seem to be able to make it work. I've searched all over the internet for something similar, but no dice. Any suggestions would be greatly appreciated.
Sub MatchingPeople()
Dim c As Variant
Dim lastrow As Long
Dim i As Variant
Dim g As Long
Dim w As Long
i = Sheets("Anthony").Name
g = Sheets("Anthony").Cells(Rows.Count, "C").End(xlUp).Row
For w = 3 To Sheets.Count
lastrow = Sheets(w).Cells(Rows.Count, 2).End(xlUp).Row
Set NewRang = Sheets("Anthony").Cells(g + 1, 3)
On Error Resume Next
With Sheets(w).Range(Cells(5, 2), Cells(lasty, 2))
Set c = .Find(i, LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Address
Do
NewRang.Value = Sheets(w).Name
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
Next w
End Sub

Here are 2 versions, one using the Find method like in your code, the other using a For loop
Option Explicit
Public Sub MatchingPeopleFind()
Dim i As Long, lrColB As Long
Dim wsCount As Long, wsName As String
Dim found As Variant, foundAdr As String
wsCount = Worksheets.Count
If wsCount >= 3 Then
For i = 3 To wsCount
With Worksheets(i)
wsName = .Name
lrColB = .Cells(.Rows.Count, 2).End(xlUp).Row
With .Range(.Cells(5, 2), .Cells(lrColB, 2))
Set found = .Find(wsName, LookIn:=xlValues)
If Not found Is Nothing Then
foundAdr = found.Address
Do
found.Offset(0, 1).Value2 = wsName
Set found = .FindNext(found)
Loop While Not found Is Nothing And found.Address <> foundAdr
End If
End With
End With
Next
End If
End Sub
Public Sub MatchingPeopleForLoop()
Dim wsCount As Long, wsName As String, i As Long, j As Long
wsCount = Worksheets.Count
If wsCount >= 3 Then
For i = 3 To wsCount
With Worksheets(i)
wsName = .Name
For j = 5 To .Cells(.Rows.Count, 2).End(xlUp).Row
If .Cells(j, 2).Value2 = wsName Then .Cells(j, 3).Value2 = wsName
Next
End With
Next
End If
End Sub

Sub Bygone()
Dim x As Long
Dim y As Long
Dim z As Long
Dim w As Long
Dim a As Long
Dim b As Long
Dim c As Long
Dim m As Long
a = Sheets.Count
For m = 3 To a
x = Sheets(m).Cells(3, 3).Value
For b = 3 To a
w = Sheets(b).Cells(Rows.Count, 1).End(xlUp).row
For z = 5 To w
y = Sheets(b).Cells(z, 1)
Select Case x
Case y
c =Sheets(m).Cells(Rows.Count,3).End(xlUp).Offset(1, 0).row
Sheets(m).Cells(c, 3).Value = Sheets(b).Name
End Select
Next z
Next b
Next m
End Sub

Related

count row cell and copy and paste

I using my code for working with c# based macro soft
but i want do my macro only using VBA, not using c#
is it can do it? not using point?
Data in B2~Bxxxxx
my c# program do copy B2 cell value and paste another worksheets K3 cell
run macro under code
Sub CopyRows()
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim bottomL As Long
Dim x As Long
bottomL = Sheets("Total").Range("L" & Rows.Count).End(xlUp).Row: x = 1
Dim c As Range
Dim lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Sheets("Total").Range("K1:K" & bottomL)
If c.Value = "Inside" Then
c.EntireRow.Copy Worksheets("filter").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
x = x + 1
End If
Next c
End Sub
then my c# program do select b3 and copy to otherworksheet k3 cell then run macro then loop that process and end be cell on Bxxxxx
anyone know that working only using VBA?
Thanks and Sorry for my Bad English
In VBA make the full code like this:
Function CopyRows()
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim bottomL As Long
Dim x As Long
bottomL = Sheets("Total").Range("L" & Rows.Count).End(xlUp).Row
x = 1
Dim c As Range Dim lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Sheets("Total").Range("K1:K" & bottomL)
If c.Value = "Inside" Then
c.EntireRow.Copy
Worksheets("filter").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
x = x + 1
End If
Next c
End Function
Sub Main()
Dim bottomB As Long
Dim y As Long
bottomB = Range("B" & Rows.Count).End(xlUp).Row
For y = 2 To bottomB
Range("B" & 2).Copy Worksheets("Total").Range("K3")
CopyRows
Next
End Sub
Then only run Sub Main().
Thanks Wasif Hasan
I already using like this code i made
Sub dual()
Application.ScreenUpdating = False ActiveSheet.DisplayPageBreaks = False
Dim i As Long
Dim totalRows As Long
Dim lastRow As Long
Dim Number As Long
Dim nowRows As Long
Dim bottomL As Long
Dim x As Long
Dim c As Range
Dim lr As Long
bottomL = Sheets("Total").Range("L" & Rows.Count).End(xlUp).Row: x = 1
lr = Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets("List")
'for looping
totalRows = .Cells(.Rows.Count, "B").End(xlUp).Row
'index of row to add from
lastRow = totalRows + 1 '<--| start pasting values one row below the last non empty one in column "B"
'data starts at row #2
For i = 2 To totalRows
If .Cells(i, 2).Value > 0 Then
Worksheets("List").Cells(i, "B").Copy
Worksheets("Total").Range("K3").PasteSpecial Paste:=xlPasteValues
lastRow = lastRow + Number
For Each c In Sheets("Total").Range("L1:L" & bottomL)
If c.Value = "Inside" Then
c.EntireRow.Copy Worksheets("filter").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
x = x + 1
End If
Next c
End If
Next i
End With Application.ScreenUpdating = True ActiveSheet.DisplayPageBreaks = True End Sub
but its lost many data at copy&paste
so it need wait paste done
so i using other program
is it any option to make waiting paste done?
Thnaks your Answer
If it is not necessary to copy and paste than try not to use that command. It is faster to just use cell1.Value = cell2.Value.
In your case you should declare a variable to count the total amount of columns in b. Then use a loop to go through b2 up to bx.
Example:
dim i as Integer
dim j as Integer
j = 3
For i = 2 to totalCount
Worksheet.Cells(2, i).Value = Worksheet2.Cells(11, j)
j = j + 1
Next i
In the above 2 = Column B and 11 = Column K

Improvement on 3 Criteria Vlookup macro

I have a list with 3 variables in the sheet "Combined" in columns A; B; C.
The workbook contains 98 sheets, with those 3 variables still in A; B; C columns but in different combinations and with a fourth column which never repeats itself, as the sheets go on, which i need to bring in the "Combined" sheet, always adding another column for the next sheet I vlookup. : A B C + D(from the next sheet) + E(from the next sheet) and so on.
I have a UDF that Vlookups on 3 based on 3 criterias and a macro that cycles through the sheets and bring the values where i want them. The problem is, it's pretty slow, left it from yesterday and its on sheet 60. Any suggestions on improving it would greatly help, Thank you in advance!
Function ThreeVlookup(Table_Range As Range, Return_Col As Long, Col1_Fnd, Col2_Fnd, Col3_Fnd)
Dim rCheck As Range, bFound As Boolean, lLoop As Long
On Error Resume Next
Set rCheck = Table_Range.Columns(1).Cells(1, 1)
With WorksheetFunction
For lLoop = 1 To .CountIf(Table_Range.Columns(1), Col1_Fnd)
Set rCheck = Table_Range.Columns(1).Find(Col1_Fnd, rCheck, xlValues, xlWhole, xlNext, xlRows, False)
If UCase(rCheck(1, 2)) = UCase(Col2_Fnd) And UCase(rCheck(1, 3)) = UCase(Col3_Fnd) Then
bFound = True
Exit For
End If
Next lLoop
End With
If bFound = True Then
ThreeVlookup = rCheck(1, Return_Col)
Else
ThreeVlookup = ""
End If
End Function
Sub test()
Dim lookupVal1 As Range, lookupVal2 As Range, lookupVal3 As Range, myString As Variant, n&, u As Long
n = Sheets("Combined").[A:A].Cells.Find("*", , , , xlByRows, xlPrevious).Row
u = 4
For j = 2 To Worksheets.Count
For i = 1 To n
Set lookupVal1 = Sheets("Combined").Cells(i, 1)
Set lookupVal2 = Sheets("Combined").Cells(i, 2)
Set lookupVal3 = Sheets("Combined").Cells(i, 3)
myString = ThreeVlookup(Sheets(j).Range("A:D"), 4, lookupVal1, lookupVal2, lookupVal3)
Sheets("Combined").Cells(i, u) = myString
Next i
u = u + 1
Next j
End Sub
Use Arrays to speed it up, my friend! Load all your sheets (or just the current sheet in the loop) into an array in VBA's memory and do the .CountIf and .Find on arrayVar(row) instead of Table_Range.Columns(1).
You will be really surprised how much quicker it goes. Do it!
Here's a tutorial I like on arrays...
http://www.cpearson.com/excel/ArraysAndRanges.aspx
Here's a guy who speed-tested an application like yours...
https://fastexcel.wordpress.com/2011/10/26/match-vs-find-vs-variant-array-vba-performance-shootout/
The basics is like this:
Sub Play_With_Arrays()
Dim varArray() As Variant
Dim lngArray() As Long
ReDim varArray(1 To 1000)
ReDim lngArray(1 To 1000)
For A = 1 To 1000
lngArray(A) = A / 2
varArray(A) = A / 2 & " examples"
Next
searchterm = 345
For B = 1 To 1000
If lngArray(B) = searchterm Then
FoundRow = B
End If
Next
searchterm2 = "5 ex"
FoundStrRowCount = 0
For C = 1 To 1000
If InStr(1, varArray(C), searchterm2, vbBinaryCompare) Then
FoundStrRowCount = FoundStrRowCount + 1
End If
Next
MsgBox (FoundRow & " in long array and " & FoundStrRowCount & " in var array")
End Sub
Something like this should be much faster:
Public Function ThreeVLookup(ByVal arg_Col1LookupVal As Variant, _
ByVal arg_Col2LookupVal As Variant, _
ByVal arg_Col3LookupVal As Variant, _
ByVal arg_LookupTable As Range, _
ByVal arg_ReturnColumn As Long) _
As Variant
Dim rConstants As Range, rFormulas As Range
Dim rAdjustedTable As Range
Dim aTable As Variant
Dim i As Long
On Error Resume Next
Set rConstants = arg_LookupTable.SpecialCells(xlCellTypeConstants)
Set rFormulas = arg_LookupTable.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
Select Case (Not rConstants Is Nothing) + 2 * (Not rFormulas Is Nothing)
Case 0: ThreeVLookup = vbNullString
Exit Function
Case -1: Set rAdjustedTable = rConstants
Case -2: Set rAdjustedTable = rFormulas
Case -3: Set rAdjustedTable = Union(rConstants, rFormulas)
End Select
If WorksheetFunction.CountIfs(rAdjustedTable.Resize(, 1), arg_Col1LookupVal, rAdjustedTable.Resize(, 1).Offset(, 1), arg_Col2LookupVal, rAdjustedTable.Resize(, 1).Offset(, 2), arg_Col3LookupVal) = 0 Then
ThreeVLookup = vbNullString
Exit Function
End If
aTable = rAdjustedTable.Value
For i = LBound(aTable, 1) To UBound(aTable, 1)
If aTable(i, 1) = arg_Col1LookupVal And aTable(i, 2) = arg_Col2LookupVal And aTable(i, 3) = arg_Col3LookupVal Then
ThreeVLookup = aTable(i, arg_ReturnColumn)
Exit Function
End If
Next i
End Function
Sub tgr()
Dim wb As Workbook
Dim wsCombined As Worksheet
Dim ws As Worksheet
Dim aResults() As Variant
Dim aCombined As Variant
Dim i As Long, j As Long
Set wb = ActiveWorkbook
Set wsCombined = wb.Sheets("Combined")
aCombined = wsCombined.Range("A1").CurrentRegion.Value
ReDim aResults(1 To UBound(aCombined, 1) - LBound(aCombined, 1) + 1, 1 To wb.Sheets.Count - 1)
For i = LBound(aCombined, 1) To UBound(aCombined, 1)
j = 0
For Each ws In wb.Sheets
If ws.Name <> wsCombined.Name Then
j = j + 1
aResults(i, j) = ThreeVLookup(aCombined(i, 1), aCombined(i, 2), aCombined(i, 3), ws.Range("A:D"), 4)
End If
Next ws
Next i
wsCombined.Range("D1").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub

Left function lost format vba codes

I am trying to split data into multiple worksheets but when I run my codes, it seems like it has lost its format. The list contains parent codes of the products I am based on splitting.
Product code has 0000-00-00 format and parent code is the first 4 digits, 0000. i.e. 0008-99-99 as product code and 0008 as parent code.
So in my result page, I m getting 8 as result not 0008, and that is why I can't get any product details in them. I tried to use left function and it is still giving me 8 not 0008 for instance. I need help with Sheets(n).Range("A1") = ws3.Cells(i, 1).Text this line of code. When I run my codes, no error just not populating results.
Option Explicit
Sub monthly()
Dim y1 As Workbook
Dim ws1, ws2, ws3 As Worksheet
Dim LR1, LR2, LR3, last As Long
Dim o, r, p As Long
Set y1 = Workbooks("Monthly Template.xlsm")
Set ws2 = y1.Sheets("Products")
Set ws3 = y1.Sheets("List")
LR2 = ws3.Cells(Rows.Count, "A").End(xlUp).Row
ws3.Activate
With ws3
Range("A1:A32").Sort key1:=Range("A1"), Order1:=xlAscending
End With
LR1 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
For o = 3 To LR1
ws2.Cells(o, 29).FormulaR1C1 = "=LEFT(RC[-21],4)"
Next o
Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As String
With Sheets("List")
j = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With Sheets("Products")
l = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For i = 1 To j
n = Sheets("List").Cells(i, 1).Text
Sheets.Add(After:=Sheets(Sheets.Count)).Name = n
Sheets(n).Range("A1") = ws3.Cells(i, 1).Text
For k = 3 To l
With Sheets(n)
If Sheets(n).Cells(1, 1).Value = Sheets("Products").Cells(k, 29).Value Then
m = .Cells(.Rows.Count, 1).End(xlUp).Row
.Rows(m + 1).Value = Sheets("Products").Rows(k).Value
End If
End With
Next k
Next i
End Sub

Assign column to an array VBA

I have this code. DataSet is set as a variant.
DataSet = Selection.Value
Works fine but is there a way I can change it to just column A, specifically cells A2 to A502? Ive tried setting that as the range but it doesn't work. It also needs to ignore blank spaces because not all of the cells will have content. I am trying to eliminate the need to highlight the cells as the entries will only be in that specific range.
Try these 2 versions:
Option Explicit
Public Sub getNonemptyCol_ForLoop()
Dim dataSet As Variant, fullCol As Variant, i As Long, j As Long
Dim lrFull As Long, lrData As Long, colRng As Range
Set colRng = ThisWorkbook.Worksheets(1).Range("A2:A502")
fullCol = colRng
lrFull = UBound(fullCol)
lrData = lrFull - colRng.SpecialCells(xlCellTypeBlanks).Count
ReDim dataSet(1 To lrData, 1 To 1)
j = 1
For i = 1 To lrFull
If Len(fullCol(i, 1)) > 0 Then
dataSet(j, 1) = fullCol(i, 1)
j = j + 1
End If
Next
End Sub
Public Sub getNonemptyCol_CopyPaste() 'without using a For loop
Dim dataSet As Variant, ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets(1)
With ws.UsedRange
ws.Activate
.Range("A2:A502").SpecialCells(xlCellTypeConstants).Copy
.Cells(1, (.Columns.Count + 1)).Activate
ActiveSheet.Paste
dataSet = ws.Columns(.Columns.Count + 1).SpecialCells(xlCellTypeConstants)
'dataSet now contains all non-blank values
ws.Columns(.Columns.Count + 1).EntireColumn.Delete
.Cells(1, 1).Activate
End With
Application.ScreenUpdating = True
End Sub
Assign with dynamic column.
Sub SetActiveColunmInArray()
Dim w As Worksheet
Dim vArray As Variant
Dim uCol As Long
Dim address As String
Set w = Plan1 'or Sheets("Plan1") or Sheets("your plan name")
w.Select
uCol = w.UsedRange.Columns.Count
address = w.Range(Cells(1, 1), Cells(1, uCol)).Cells.address
vArray = Range(address).Value2
End Sub

VBA search column for strings and copy row to new worksheet

Not really good at VBA here. Found and edited some code that I believe can help me.
I need this code to search 2 columns (L and M) for any string in those columns that ends with _LC _LR etc... Example: xxxxxxxx_LC .
If the cell ends with anything in the array, I need the row to be copied to a new sheet. Here is what I have:
Option Explicit
Sub Test()
Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String
Dim maxKeywords As Integer
maxKeywords = 6
ReDim keywords(1 To maxKeywords)
maxKeywords(1) = "_LC"
maxKeywords(2) = "_LR"
maxKeywords(3) = "_LF"
maxKeywords(4) = "_W"
maxKeywords(5) = "_R"
maxKeywords(6) = "_RW"
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For Each rngCell In Range("L2:L, M2:M" & lngLstRow)
For i = 1 To maxKeywords
If keywords(i) = rngCell.Value Then
rngCell.EntireRow.Copy
Sheets("sheet1").Select
Range("L65536, M65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues
Sheets("Results").Select
End If
Next i
Next
End Sub
Okay, the issue I think is with your variable declarations. Before I continue, I will echo #GradeEhBacon's comment that if you can't read this and understand what's going on, you may want to take some time to learn VBA before running.
This should work, AFAIK. You didn't specify which sheet has what info, so that may have to be tweaked. Try the below, and let me know what is/isn't working:
Sub Test()
Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String, maxKeywords() As String
Dim totalKeywords As Integer, i&
Dim ws As Worksheet, resultsWS As Worksheet
Set ws = Sheets("Sheet1")
Set resultsWS = Sheets("Results")
totalKeywords = 6
ReDim keywords(1 To totalKeywords)
ReDim maxKeywords(1 To totalKeywords)
maxKeywords(1) = "_LC"
maxKeywords(2) = "_LR"
maxKeywords(3) = "_LF"
maxKeywords(4) = "_W"
maxKeywords(5) = "_R"
maxKeywords(6) = "_RW"
lngLstRow = ws.UsedRange.Rows.Count 'Assuming "Sheet1" is what you want to get the last range of.
Dim k& ' create a Long to use as Column numbers for the loop
For k = 12 To 13 ' 12 is column L, 13 is M
With ws 'I'm assuming your Ranges are on the "Sheet1" worksheet
For Each rngCell In .Range(.Cells(1, k), .Cells(lngLstRow, k))
For i = LBound(maxKeywords) To UBound(maxKeywords)
If maxKeywords(i) = Right(rngCell.Value, 3) or maxKeywords(i) = Right(rngCell.Value, 2) Then
' rngCell.EntireRow.Copy
' ws.Range("L65536, M65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
resultsWS.Cells(65536, k).End(xlUp).Offset(1, 0).EntireRow.Value = rngCell.EntireRow.Value
End If
Next i
Next rngCell
End With
Next k
End Sub
This might be what you are looking for:
==================================================
Option Explicit
Sub Test()
Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String
Dim maxKeywords, i, j, k As Integer
maxKeywords = 6
ReDim keywords(1 To maxKeywords)
keywords(1) = "_LC"
keywords(2) = "_LR"
keywords(3) = "_LF"
keywords(4) = "_W"
keywords(5) = "_R"
keywords(6) = "_RW"
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For j = 1 To lngLstRow
For i = 1 To maxKeywords
If keywords(i) = Right(Sheets("Results").Range("L" & j).Value, Len(keywords(i))) Or _
keywords(i) = Right(Sheets("Results").Range("M" & j).Value, Len(keywords(i))) Then
k = k + 1
Rows(j & ":" & j).Copy
Sheets("sheet1").Select
Range("A" & k).Select
ActiveSheet.Paste
End If
Next i
Next j
End Sub