I am trying to sort the data on sheet 2 to sheet 9 by text in the string sby.
I think logic is simple from the code below.
But the code below gave
runtime-error 1004; Select Method of Range Class Failed for the line wk.Rows(j).EntireRow.Select
Update 1:
I don't get the error now but it's stuck in [running] mode for a long time I had to break the code execution. I am trying to implement the I/O logic below. I think my code should work but it's either taking very long or stuck in an infinite loop. Can you help
Input:
col B
Commercial
Tech
Operation
Commercial
Commercial
.
.
.
.
Output:
col B
Commercial
Commercial
Commercial
Tech
Operation
.
.
.
Code
Option Explicit
Sub SortByCommercial()
Dim wk As Worksheet
Dim sby, FinalRow, i, j, p
Dim WsCount As Integer
WsCount = ActiveWorkbook.Worksheets.Count
Dim wb As Workbook
Set wb = ActiveWorkbook
sby = "Commercial"
For i = 2 To WsCount
Set wk = Sheets(i)
FinalRow = wk.Range("A900000").End(xlUp).Row
p = FinalRow + 1
For j = 2 To FinalRow
If Trim(wk.Range("B" & j).Text) <> sby Then
wk.Rows(j).EntireRow.Select
Selection.Cut
wk.Range("A" & p).Select
wk.Paste
Rows(j).EntireRow.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Application.CutCopyMode = False
j = j - 1
Else: End If
Next j
Next i
End Sub
Sub SortByCommercial()
Dim wk As Worksheet
Dim sby, FinalRow, i, j, p
Dim WsCount As Integer
WsCount = ActiveWorkbook.Worksheets.Count
Dim wb As Workbook
Dim lngRowTemp as Long
Set wb = ActiveWorkbook
sby = "Commercial"
For i = 2 To WsCount
Set wk = Sheets(i)
Sheets(i).Activate
For j = 2 To FinalRow
FinalRow = wk.Range("A900000").End(xlUp).Row + 1
lngRowTemp = FinalRow -1
If Trim(wk.Range("B" & j).Text) <> sby Then
wk.Rows(j).EntireRow.Select
Selection.Cut
wk.Range("A" & FinalRow).Select
wk.Paste
Application.CutCopyMode = False
End If
Next j
for j = lngRowTemp to 2 step -1
if cells("B" & j).value = "" then
cells("B" & j).EntireRow.Delete
end if
next j
Next i
End Sub
Related
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
I'm trying to run a macro but now it keeps freezing excel.
It runs with 10 cells, but when the macro is applied to almost two hundred, it freezes and crashes.
Sub eancheck()
Dim s1 As Worksheet, s2 As Worksheet
Dim Msg As String
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet3")
Dim lr1 As Long, lr2 As Long
lr1 = s1.Range("A" & Rows.Count).End(xlUp).Row
lr2 = s2.Range("a" & Rows.Count).End(xlUp).Row
Dim i As Long, j As Long
Application.ScreenUpdating = False
For i = 2 To lr1
s1.Cells(i, "D").Interior.ColorIndex = 0
For j = 2 To lr2
If s2.Range("A" & j) = s1.Range("D" & i) Then
's1.Range("D" & i) = s2.Range("B" & j)
s1.Cells(i, "D").Interior.ColorIndex = 3
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
I'm having problems with other macros too, and i think is because of the size of the range. How can i fix it?
Note: The macro runs when searching 10 values in a sheet with two columns with almost 200.000 values each, but when instead of 10 is 200, crashes.
Use conditional formatting in your sheet1 with formula and apply it on range like D2:D5000 or whatever is suitable.
=COUNTIF(Sheet3!A2,D2)>0
Try Declaring all the required variables separately.
Use Application.ScreenUpdating = false in the beginning of the program.
Your first line of for loop can be outside the for loop as well.
Use Collections to make the checks.
For Example, I started with data like this on Sheet 1 Col A,
And data like this on Sheet 3 Col A.
And this is the Macro that I have,
Sub eancheck()
Application.ScreenUpdating = False
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim Msg As String
Dim lr1 As Long
Dim lr2 As Long
Dim i As Long
Dim j As Long
Dim Sheet1ObjectsCol As Collection
Dim Sheet3ObjectsCol As Collection
Dim IdentifierCol As Collection
Set s1 = ThisWorkbook.Sheets("Sheet1")
Set s2 = ThisWorkbook.Sheets("Sheet3")
Set Sheet1ObjectsCol = New Collection
Set Sheet3ObjectsCol = New Collection
Set IdentifierCol = New Collection
lr1 = s1.Range("A" & Rows.Count).End(xlUp).Row
lr2 = s2.Range("a" & Rows.Count).End(xlUp).Row
s1.Range("D2" & ":" & "D" & lr1).Interior.ColorIndex = 0
'Load the collections
For i = 2 To lr1
Sheet1ObjectsCol.Add s1.Range("A" & i).Value
Next
'Load the collections
On Error Resume Next
For i = 2 To lr2
Sheet3ObjectsCol.Add s2.Range("A" & i).Value, CStr(s2.Range("A" & i).Value)
Next
'Create the Identifier Collection
For i = 1 To Sheet1ObjectsCol.Count
ColorValReq = 0
For j = 1 To Sheet3ObjectsCol.Count
If Sheet1ObjectsCol(i) = Sheet3ObjectsCol(j) Then
ColorValReq = 3
GoTo Idenitified
End If
Next
Idenitified:
IdentifierCol.Add ColorValReq
Next
For i = 1 To IdentifierCol.Count
j = i + 1
If IdentifierCol(i) = 3 then
s1.Range("D" & j).Interior.ColorIndex = IdentifierCol(i)
End if
Next
Application.ScreenUpdating = True
End Sub
And this is the output I got,
I have the following VBA code for excel
Dim k As Integer, z As Integer
Dim sourceSht As Worksheet
Dim destSht As Worksheet
z = 0
Set sourceSht = Sheets("sheet1")
Set destSht = Sheets("sheet2")
DoEvents
For k = 1 To 5000
If k < 3 Or (k - 1) Mod 3 <> 0 Then
z = z + 1
sourceSht.Columns(k).Copy destSht.Columns(z)
End If
Next
This code was working perfectly for rows (changed this part"sourceSht.Columns(k).Copy destSht.Columns(z)").
but I can not make it work for columns. I want excel to copy the first 2 columns then skip the third one, then copy 2 again, skip one and etc... can somebody help me and explain what am I doing wrong?
I'm going to ignore the use of mod and do a Step 3 with the loop:
Dim i as Long, j as Long
For i = 1 to 5000 Step 3
With sourceSht
If j = 0 Then
j = 1
Else
j = j + 2 'Copying 2 columns over, so adding 2 each time
End If
.Range(.Columns(i),.Columns(i+1)).Copy destSht.Range( destSht.Columns(j), destSht.Column(j+1))
End With
Next i
Something like that should do it for you
Alternate:
Sub tgr()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rCopy As Range
Dim rLast As Range
Dim LastCol As Long
Dim i As Long
Set wsSource = ActiveWorkbook.Sheets("Sheet1")
Set wsDest = ActiveWorkbook.Sheets("Sheet2")
On Error Resume Next
Set rLast = wsSource.Cells.Find("*", wsSource.Range("A1"), xlFormulas, , xlByColumns, xlPrevious)
On Error GoTo 0
If rLast Is Nothing Then Exit Sub 'No data
LastCol = rLast.Column
Set rCopy = wsSource.Range("A:B")
For i = 4 To LastCol Step 3
Set rCopy = Union(rCopy, wsSource.Columns(i).Resize(, 2))
Next i
rCopy.Copy wsDest.Range("A1")
End Sub
Try this (use count for the number of time you need to copy columns, t for the first columns you need to copy):
Sub copy_columns()
t = 1
Count = 1
Do Until Count = 10
Range(Columns(t), Columns(t + 1)).Copy
Cells(1, t + 3).Select
Selection.PasteSpecial Paste:=xlPasteValues
t = t + 3
Count = Count + 1
Loop
End Sub
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
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