I'm trying to copy/paste values from multiple sheets into one.
I have the loop down but the macro overwrites the values in the same column where the data is being written.
Sub Main()
MedRT_EPC Sheets("Chemical Structure (14)")
MedRT_EPC Sheets("Enzymes (19)")
MedRT_EPC Sheets("Diuretics (5)")
MedRT_EPC Sheets("Imaging Agents (12)")
MedRT_EPC Sheets("Vitamins (27)")
End Sub
Sub MedRT_EPC(ws As Worksheet)
' Copy EPC cells Macro
Dim bottomL As Integer
Dim x As Integer
bottomL = ws.Range("I" & Rows.Count).End(xlUp).Row: x = 1
Dim c As Range
For Each c In ws.Range("I:I" & bottomI)
If c.Value = "EPC" Then
c.EntireRow.Copy Worksheets("sheet4").Range("A" & x)
x = x + 1
End If
Next c
End Sub
I've tried adding this:
Dim LastTargetRow As Long
' code here
With ws
LastTargetRow = .Range("I" & Rows.Count).End(xlUp).Row + 1
End With
' code here
As I said above, Autofilter would be quicker (or using Find) but if you stick with a loop, the main thing is not to start each worksheet at row 1 for your paste range.
Sub MedRT_EPC(ws As Worksheet)
' Copy EPC cells Macro
Dim bottomL As Long, x As Long
bottomL = ws.Range("I" & Rows.Count).End(xlUp).Row
Dim c As Range
For Each c In ws.Range("I2:I" & bottomL) 'or I1 as applicable
If c.Value = "EPC" Then
x = Worksheets("sheet4").Range("I" & Rows.Count).End(xlUp).Row + 1
c.EntireRow.Copy Worksheets("sheet4").Range("A" & x)
End If
Next c
End Sub
Your issue is that the "x" does not change. Try the below code. Fill the x1, x2, x3, x4, and x5 with the numbers you want.
Sub Main()
MedRT_EPC Sheets("Chemical Structure (14)",x1)
MedRT_EPC Sheets("Enzymes (19)",x2)
MedRT_EPC Sheets("Diuretics (5)",x3)
MedRT_EPC Sheets("Imaging Agents (12)",x4)
MedRT_EPC Sheets("Vitamins (27)"x5)
End Sub
Sub MedRT_EPC(ws As Worksheet, x as Integer)
' Copy EPC cells Macro
Dim bottomL As Integer
bottomL = ws.Range("I" & Rows.Count).End(xlUp).Row: x = 1
Dim c As Range
For Each c In ws.Range("I:I" & bottomI)
If c.Value = "EPC" Then
c.EntireRow.Copy Worksheets("sheet4").Range("A" & x)
End If
Next c
End Sub
Related
Okay, so I feel like I am getting closer but I am running in to an object error. I am trying to replace old values in an excel sheet with the new charge values. Here is an example of what I am trying to do.
This is an example of the type of table I might start out with.
This is what I want it to look like after I run the VBA
Here is what I have so far.
Sub Testing()
Dim x As Integer
Dim UpdateRng As Range
Dim SelectRng As Range
v = 2
Application.ScreenUpdating = False
' Get count
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
Range("B2").Select
' Cycle through loop
For x = 1 To NumRows
Set SelectRng = Range("C" & v & ":" & "F" & v) 'Set range
If "A" & v.Vaule = " " Or v.Value = "" Then GoTo NextV
For Each UpdateRng In SelectRng
If UpdateRng.Value > 0 Then
UpdateRng.Value = Range("A" & v).Value
End If
Next
NextV:
v = v + 1
Next
Application.ScreenUpdating = True
End Sub
Add Option Explicit to the top of the module and declare all variables.
Avoid using GoTo as that generally creates spaghetti code.
Use End(xlUp) to determine the last row.
Avoid using Select.
Use Long instead of Integer.
Sub Testing()
Dim ws As Worksheet
Set ws = ActiveSheet
With ws
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
Dim i As Long
For i = 2 To lastRow
With ws
If Not IsEmpty(.Range("A" & i).Value) Then
.Range("C" & i & ":F" & i).Replace "*", .Range("A" & i).Value
End If
End With
Next
End Sub
Note that this considers all values when replacing, not just values greater than 0. Though I think the >0 check is essentially checking if the cells in columns C:F are not empty.
I got it working with this. However, Bigben's is much cleaner.
Sub Testing()
Dim x As Integer
Dim UpdateRng As Range
Dim SelectRng As Range
v = 2
Application.ScreenUpdating = False
' Get count
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
Range("B2").Select
' Cycle through loop
For x = 1 To NumRows
Set SelectRng = Range("C" & v & ":" & "F" & v) 'Set range
If Range("A" & v).Value = " " Or Range("A" & v).Value = "" Then GoTo NextV
For Each UpdateRng In SelectRng
If UpdateRng.Value > 0 Then
UpdateRng.Value = Range("A" & v).Value
End If
Next
NextV:
v = v + 1
Next
Application.ScreenUpdating = True
End Sub
I have in E, F and I columns something written. In E and F its a name and in I its a number. In I column there are some cells with number and rest are blank. When ever its a number, I should copy the names from E1, F1 and copy it to C3 and D3 respectively. I have written a code but its not functioning properly. Could you please help me.
Option Explicit
Sub copy()
Dim cell As Long
Dim nr As Integer
Dim rng As range
Dim i As Long
range("G1:G15").Select
Selection.CurrentRegion.Select
nr = Selection.Rows.Count
For i = 2 To nr
'test if cell is empty
If ActiveCell(i, 7) = "" Then
'write to adjacent cell
ActiveCell = ActiveCell + 1
Else
ActiveCell.Offset(-3, -2).Value.copy ActiveCell.Offset(-3, 0)
End If
Next i
End Sub
Option Explicit
Sub copy()
Dim Row As Long
Dim Col As Long
Row = 2
Col = 9
Do Until Cells(Row, 5).Value = ""
If IsNumeric(Cells(Row, Col)) = True Then
Range("E" & Row & ":F" & Row).copy
Range("C" & Row).PasteSpecial (xlPasteValues)
End If
Row = Row + 1
Loop
Application.CutCopyMode = False
End Sub
I have some history working with VBA, but can't seem to find the solution to this problem. I found an iteration process to select a cell, do a process, and then select the next cell and do the process again, until NULL. I am having a problem outputting each of the processes solutions into the next column. Here is what I have:
Sub Name ()
Dim X As Integer
Dim MyString as String
Application.ScreenUpdating = False
NumRows = Range("D2", Range("D2").End(xlDown)).Rows.Count
Range("D2").Select
For X = 1 To NumRows
MyString = ActiveCell.Value
MyString = Right(MyString, Len(MyString)-6)
Range("I2 to I#").Value = MyString
ActiveCell.Offset(1,0).Select
Next X
End Sub
Range("I2 to I#").Value = MyString is the line that I need help with. I need it to increment to I3, I4, I5, etc. until it reaches NumRows count.
When working with Cells the best way to loop through them is For Each Cell in Range so taking this and as comments told you to avoid selecting, this should help you:
Option Explicit
Sub Name()
Dim C As Range, MyRange As Range
Dim LastRow As Long
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("MySheet") 'Change MySheet for your working sheet name
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row on column D
Set MyRange = .Range("D2:D" & LastRow) 'declare your working range
For Each C In MyRange
If Not C = vbNullString Then .Cells(C.Row, "I") = Right(C, Len(C) - 6)
Next C
End With
Application.ScreenUpdating = True
End Sub
Another solution is Do Until. You could use this method if you dont have empty cells in the middle of your data.
Option Explicit
Sub Test()
Dim StartingPoint As Long
StartingPoint = 2 'Set the line to begin
With ThisWorkbook.Worksheets("Sheet1") 'Set the worksheet
Do Until .Cells(StartingPoint, "D").Value = "" 'Repeat the process until you find empty cell
.Cells(StartingPoint, "I").Value = Right(.Cells(StartingPoint, "D").Value, Len(.Cells(StartingPoint, "D").Value) - 6)
StartingPoint = StartingPoint + 1
Loop
End With
End Sub
basically I need to split a cell that has a few values, seperated by a comma into more cells. Then i need to create the exact amount of the cells under the new cells to be able to transpose this range later to have a new table.
In the picture you can see an example of what I have and what I need. I needed to anonymyze the data. Also I have hundreds of rows that need to changed like the 2 in the example.
Ths is my current code:
Sub texttocolumns()
Dim rng As Range
Dim x As Integer
x = ActiveSheet.UsedRange.Rows.Count
For i = x - 2 To 1
Cells(2 + i, 8).texttocolumns _
Destination:=Cells(2 + i, 9), _
Comma:=True
k = Application.WorksheetFunction.CountA("A" & "2 + i"" & "":" & "AT1")
Cells(2 + i, 1).Rows(k).Insert
Next i
End Sub
I can't find my mistake at the moment, could someone please help me out? thanks!
Since the output result is posted to a different location the expensive task of inserting rows can be avoided.
Try this procedure, which also avoids working with the source range by generating from it two Arrays:
An array containing the fixed fields
An array containing the field that needs to be split
The Procedure:
Sub Range_Split_A_Field()
Dim wsTrg As Worksheet, rgOutput As Range
Dim aFld_1To5 As Variant, aFld_6 As Variant
Dim aFld As Variant
Dim lRow As Long, L As Long
lRow = 3
Set wsTrg = ThisWorkbook.Sheets("Sht(2)")
Application.Goto wsTrg.Cells(1), 1
With wsTrg.Cells(lRow, 1).CurrentRegion
Set rgOutput = .Rows(1).Offset(0, 10)
.Rows(1).Copy
rgOutput.PasteSpecial
Application.CutCopyMode = False
aFld_1To5 = .Offset(1, 0).Resize(-1 + .Rows.Count, 5).Value2
aFld_6 = .Offset(1, 5).Resize(-1 + .Rows.Count, 1).Value2
End With
lRow = 1
For L = 1 To UBound(aFld_1To5)
aFld = aFld_6(L, 1)
If aFld = vbNullString Then
rgOutput.Offset(lRow).Resize(1, 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(1, 1).Value = aFld
lRow = 1 + lRow
Else
aFld = Split(aFld, Chr(44))
aFld = WorksheetFunction.Transpose(aFld)
rgOutput.Offset(lRow).Resize(UBound(aFld), 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(UBound(aFld), 1).Value = aFld
lRow = lRow + UBound(aFld)
End If: Next
End Sub
Please see the following pages for a better understanding of the resources used:
Application.Goto Method (Excel)
With Statement
Range Object (Excel)
Chr Function
UBound Function
WorksheetFunction Object (Excel)
Would something like this work:
'A1 = A,B,C,D,E,F,G
'A2 = 1,2,3,4,5,6,7
'A3 = A!B!C!D!E!F!G
'Test procedure will result in:
'A - G in cells A1:A7
'1,2,3,4,5,6,7 in cell A8.
'A - G in cells A9:A15
Sub Test()
TextToColumns Sheet1.Range("A1")
TextToColumns Sheet1.Range("A9"), "!"
End Sub
Public Sub TextToColumns(Target As Range, Optional Delimiter As String = ",")
Dim rng As Range
Dim lCount As Long
Dim x As Long
'How many delimiters in target string?
lCount = Len(Target) - Len(Replace(Target, Delimiter, ""))
'Add the blank rows.
For x = 1 To lCount + 1
Target.Offset(1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next x
'Split the string.
Target.TextToColumns Target, xlDelimited, xlTextQualifierNone, , , , , , True, Delimiter
'Use TRANSPOSE formula to paste to rows and then remove formula.
With Target.Offset(1).Resize(lCount + 1, 1)
.FormulaArray = "=TRANSPOSE(R" & Target.Row & "C:R" & Target.Row & "C" & lCount + 1 & ")"
.Value = .Value
End With
'Delete the original text string.
Target.EntireRow.Delete
End Sub
Edit:
To use from the Macro dialog box you could add this small procedure:
Public Sub Test()
Dim y As Long
y = ActiveSheet.UsedRange.Rows.Count
With ActiveSheet
For y = 5 To 1 Step -1
TextToColumns .Cells(y, 1)
Next y
End With
End Sub
Note: ActiveSheet.UsedRange.Rows.Count is a terrible way to find the last row.
See this thread: Error in finding last used cell in VBA
In column B on three (Bakery, Floral, Grocery) of the five sheets in my workbook, I want to find rows that have the word Flyer in column B. There will be multiple rows in each worksheet that have the word Flyer in column B. When it finds the word Flyer, it will paste the entire row into Sheet1.
I go this to work on one tab, but want the same code to search all three tabs (but NOT all five ... this is the issue) and paste all of the rows with the word Flyer in column B into Sheet1.
My code (works, but only on the Bakery tab):
Sub CopyRowsFlyer()
'This looks in the Bakery tab and moves everything that has "Flyer" in column B to Sheet 1
Dim bottomB As Integer
Dim x As Integer
bottomB = Sheets("Bakery").Range("B" & Rows.Count).End(xlUp).Row: x = 1
Dim c As Range
For Each c In Sheets("Bakery").Range("B3:B" & bottomB)
If c.Value = "Flyer" Then
c.EntireRow.Copy Worksheets("sheet1").Range("A" & x)
x = x + 1
End If
Next c
End Sub
Similar to other solutions posted. Pretty simple. Replaces bounding for range checking. Fewest variables. No mid-execution dimensioning.
Sub CopyRowsFlyer()
Dim strSh As Variant, c As Range, x As Integer
x = 1
For Each strSh In Array("Bakery", "Floral", "Grocery")
For Each c In Worksheets(strSh).Range("B:B")
If c = "" and c.Row > 2 Then
Exit For
ElseIf c = "Flyer" and c.Row > 2 Then
c.EntireRow.Copy Worksheets("Sheet1").Range("A" & x)
x = x + 1
End If
Next
Next
End Sub
You just want to loop through the three sheets you want. Try this:
Sub CopyRowsFlyer()
'This looks in the Bakery tab and moves everything that has "Flyer" in column B to Sheet 1
Dim bottomB As Integer
Dim x As Integer
Dim SheetsArray() As Variant
Dim ws As WorkSheet
Dim i As Integer
SheetsArray = Array("Bakery", "Sheet2Name", "Sheet3Name")
For i = LBound(SheetsArray) To UBound(SheetsArray)
Set ws = Sheets(SheetsArray(i))
bottomB = ws.Range("B" & Rows.Count).End(xlUp).Row: x = 1
Dim c As Range
For Each c In ws.Range("B3:B" & bottomB)
If c.Value = "Flyer" Then
c.EntireRow.Copy Worksheets("sheet1").Range("A" & x)
x = x + 1
End If
Next c
Next i
End Sub
You can substitute an element of a string array for the ID in Sheets.
Here is your code modified to reflect.
Sub CopyRowsFlyer()
Dim bottomB As Integer
Dim x As Integer
Dim sheetName(1 to 3) As String, i as Integer
sheetName(1) = "Bakery"
sheetName(2) = "Floral"
sheetName(3) = "Grocery"
x=1
For i = 1 to 3
bottomB = Sheets(sheetName(i)).Range("B" & Rows.Count).End(xlUp).Row
Dim c As Range
For Each c In Sheets(sheetName(i)).Range("B3:B" & bottomB)
If c.Value = "Flyer" Then
c.EntireRow.Copy Worksheets("sheet1").Range("A" & x)
x = x + 1
End If
Next c
Next i
End Sub
Store the desired worksheet names in an array and loop through them.
Sub CopyRowsFlyer()
Dim bottomB As Long, b As Long, x As Long
Dim w As Long, vWSs As Variant
vWSs = Array("Bakery", "Floral", "Grocery")
x = 1
For w = LBound(vWSs) To UBound(vWSs)
With Worksheets(vWSs(w))
bottomB = .Range("B" & Rows.Count).End(xlUp).Row
For b = 3 To bottomB
If LCase(.Cells(b, "B").Value) = "flyer" Then
.Rows(b).EntireRow.Copy Worksheets("sheet1").Range("A" & x)
x = x + 1
End If
Next b
End With
Next w
End Sub
While this method of looping through the cells in each worksheet's column B is considered inefficient compared to other methods like the .Range.Find method, it will not make a lot of difference on smaller sets of data. If you have a large number of rows on each worksheet to examine, you may wish to explore other more direct avenues of retrieving the information.