I currently have this code
Sub TFS_Data_TC_Custody_Failed()
Dim bottomL As Integer
Dim x As Integer
bottomL = Sheets("TFS_Data_TC_Custody").Range("E" & Rows.Count).End(xlUp).Row: x = 3
Dim c As Range
For Each c In Sheets("TFS_Data_TC_Custody").Range("E2:E" & bottomL)
If c.Value = "Failed" Then
c.EntireRow.Copy Worksheets("TC_Custody_Failed").Range("A" & x)
x = x + 1
End If
Next c End Sub
I want to change the EntireRow to only copy selected Columns e.g. A,C,D of the rows that it has identified.
One possibility is to create another Range object and use the Intersect method to keep only columns A,C, and D of the EntireRow
Sub TFS_Data_TC_Custody_Failed()
Dim bottomL As Integer
Dim x As Integer
bottomL = Sheets("TFS_Data_TC_Custody").Range("E" & Rows.Count).End(xlUp).Row: x = 3
Dim c As Range
Dim copyRange As Range
For Each c In Sheets("TFS_Data_TC_Custody").Range("E2:E" & bottomL)
If c.Value = "Failed" Then
Set copyRange = Application.Intersect(c.EntireRow, _
Sheets("TFS_Data_TC_Custody").Range("A:A,C:D"))
copyRange.Copy Worksheets("TC_Custody_Failed").Range("A" & x)
x = x + 1
End If
Next c
End Sub
Personally I would construct my code entirely differently but here is one way of doing it based on what you have. I didn't fully understand where you are placing the copied data so you may need to amend that part.
Dim bottomL As Integer
Dim x As Integer
bottomL = Sheets("TFS_Data_TC_Custody").Range("E" & Rows.Count).End(xlUp).Row
x = 3
Dim c As Range
For Each c In Sheets("TFS_Data_TC_Custody").Range("E2:E" & bottomL)
If c.Value = "Failed" Then
c.Cells(1, 1).Copy Worksheets("TC_Custody_Failed").Range("A" & x)
c.Cells(1, 3).Copy Worksheets("TC_Custody_Failed").Range("A" & x + 1)
c.Cells(1, 4).Copy Worksheets("TC_Custody_Failed").Range("A" & x + 2)
x = x + 3
End If
Next c
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 came across a macro that compares data pasted in column B with column A and highlights column B if not an Exact match with column A.
Sub HighlightNoMatch()
Dim r As Long
Dim m As Long
m = Range("B" & Rows.Count).End(xlUp).Row
Range("B1:B" & m).Interior.ColorIndex = xlColorIndexNone
For r = 1 To m
If Evaluate("ISERROR(MATCH(TRUE,EXACT(B" & r & ",$A$1:$A$30),0))") Then
Range("B" & r).Interior.Color = vbRed
End If
Next r
End Sub
How do I change the code to achieve as below -
I want the code to highlight Column F on sheet2, if it is not an exact match with data in Column B on sheet1."
Rather than having a fixed range ($A$1:$A$30) I would loop through each value in the range and check for a match:
Sub HighlightNoMatch()
Dim t As Long
Dim m As Long
m = Worksheets("Sheet2").Range("F" & Rows.Count).End(xlUp).Row
t = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
Worksheets("Sheet2").Range("F1:F" & m).Interior.ColorIndex = xlColorIndexNone
For x1 = 1 To m
For x2 = 1 To t
If Worksheets("Sheet2").Range("F" & x1).Value = Worksheets("Sheet1").Range("B" & x2).Value Then
Exit For
ElseIf Worksheets("Sheet2").Range("F" & x1).Value <> Worksheets("Sheet1").Range("B" & x2).Value And x2 = t Then
Worksheets("Sheet2").Range("F" & x1).Interior.Color = vbRed
End If
Next x2
Next x1
End Sub
column A and Column C is the range and column B is the reference value which I have to compare with Column A and Column C .
Eg: (B>A) and (B
Basically I want to check whether column B falls between Column A and column C
Here is the code which I have prepared but this is not working and this is for single cell:
Sub a()
Dim x As Integer
Dim y As Integer
x = Worksheets("Sheet1").Range("A1").Value
y = Worksheets("Sheet1").Range("B1").Value
Z = Worksheets("Sheet1").Range("C1").Value
If Z > x Then
Worksheets("Sheet1").Range("D1") = "Correct"
End If
End Sub
you can do this way:
Sub main()
With Worksheets("Sheet1")
With .Range("D1:D" & .Cells(.Rows.Count, 1).End(xlUp).row)
.FormulaR1C1 = "=IF(AND(RC2>=RC1,RC2<=RC3),""Correct"",""Wrong"")"
.Value = .Value
End With
End With
End Sub
You can use a simple formula for this:
=IF(AND(B1>=A1,B1<=C1),"Correct","Wrong")
If you still need vba then use this:
Sub RANGEFALL()
Dim wk As Worksheet, frow As Long, i As Long
Set wk = Sheet1
frow = wk.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To frow
If wk.Range("B" & i).Value >= wk.Range("A" & i).Value And wk.Range("B" & i).Value <= wk.Range("C" & i).Value Then
wk.Range("D" & i).Value = "Correct"
Else
wk.Range("D" & i).Value = "Wrong"
End If
Next i
End Sub
I'm trying to do a cycle, where IF the condition is true and cell n index (column E) is the same as cell's n+1 index, to copy the column C value into column G.
Unfortunately last C column value is not copied to column G, so i simply resolved it with a string:
Sheets("Report KIT").Range("G" & n) = Sheets("Report KIT").Range("C" & n).Value
after Do While. Can anyone help with it please? Thanks
Sub Macroarea1()
Dim ws As Worksheet
Dim LastRow As Long
Dim LastRow1 As Long, LastRow3 As Long
Dim i, n As Integer, x As Integer, y As Integer
Set ws = ActiveWorkbook.Sheets("Report KIT")
If Sheets("Migrazioni").Range("F" & 7) = "si" Then
n = Sheets("Migrazioni").Range("N" & 7).Value
Do While _
Sheets("Report KIT").Range("E" & n) = Sheets("Report KIT").Range("E" & n + 1)
Sheets("Report KIT").Range("G" & n) = Sheets("Report KIT").Range("C" & n).Value
n = n + 1
Loop
Sheets("Report KIT").Range("G" & n) = Sheets("Report KIT").Range("C" & n).Value
End If
End Sub
I cleaned up your looping a bit and added a check for the E column value first and modified the loop to check to make sure each row meets the initial E column value to test it. I tested this with your sample data it produced the result you wanted. Sometimes these conditional loops can be tricky to figure out!
Sub Macroarea1()
Dim wsR As Worksheet, wsN As Worksheet
Dim LastRow As Long
Dim LastRow1 As Long, LastRow3 As Long
Dim i, n As Integer, x As Integer, y As Integer
Set wsR = ActiveWorkbook.Sheets("Report KIT")
Set wsN = ActiveWorkbook.Sheets("Migrazioni")
If wsN.Range("F7") = "si" Then
n = wsN.Range("N7").Value
i = wsR.Range("E" & n).Value
Do Until wsR.Range("E" & n) <> i
wsR.Range("G" & n).Value = wsR.Range("C" & n).Value
n = n + 1
Loop
End If
End Sub
I have a columns filled with string cells separated by spaces such as:
"abc def ghi jkl"
"abcde fghi jkl"
"abcdef ghijkl"
"abcdefghijkl"
My objectives are:
When there is four words I take each of the first letters of each word
When there is three words I take the first two letters of the first word and then each of the first letters of the following words
When there is two words I take the first two letters of each word
When there is only one word I take the first four letters
For each case I copy the resulting four letters found into another cell on the same row.
Being new to vba I didn't go very far. I started with Case 1 but it is incomplete and not returning anything:
Sub MyMacro()
Dim r As Range
Dim a, b, c, d, s As String
Dim v As Variant
Dim w As Worksheet
Set w = Worksheets("Sheet1")
w.Activate
Set r = w.Range("B1").End(xlDown).Rows
For Each v In r.Cells
If UBound(Split(v, " ")) = 3 Then
a = Left(Split(v, " ")(0), 1)
b = Left(Split(v, " ")(1), 1)
c = Left(Split(v, " ")(2), 1)
d = Left(Split(v, " ")(3), 1)
End If
Next
End Sub
Why aren't a, b, c and d not returning anything?
While I am looping through the cells of the range, how do I say that I want to copy the concatenated values of a, b, c and d into an adjacent cell?
Edited to replace "#" with " ".
Sub MyMacro()
Dim r As Range
Dim a, b, c, d, s As String
Dim v As Variant
Dim w As Worksheet
Dim arr, res
Set w = Worksheets("Sheet1")
w.Activate
Set r = w.Range(w.Range("B1"), w.Range("B1").End(xlDown))
For Each v In r.Cells
arr = Split(v.Value, " ")
select case ubound(arr)
case 0: res=left(arr(0),4)
case 1:'etc
case 2:'etc
case 3:'res = left(arr(0),1) & left(arr(1),1)'...etc
case else: res = "???"
End Select
v.offset(0,1).value=res
Next v
End Sub
Let's say your worksheet looks like this
Then try this
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, n As Long
Dim MyAr, sval
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
sval = .Range("A" & i).Value
If InStr(1, sval, " ") Then
MyAr = Split(sval, " ")
n = UBound(MyAr) + 1
Select Case n
Case 2:
.Range("B" & i).Value = Left(MyAr(0), 2) & Left(MyAr(1), 2)
Case 3
.Range("B" & i).Value = Left(MyAr(0), 2) & Left(MyAr(1), 1) & Left(MyAr(2), 1)
Case 4
.Range("B" & i).Value = Left(MyAr(0), 1) & Left(MyAr(1), 1) & _
Left(MyAr(2), 1) & Left(MyAr(3), 1)
End Select
Else
.Range("B" & i).Value = Left(sval, 4)
End If
Next i
End With
End Sub
Output