I need this VBA to instead of just putting the value "X" in cells to grab the text from a cell within the work book. The cell is B4 within the Sheet "Order Entry". Thanks.
Sub Check()
Dim dat As Variant
Dim rng As Range
Dim i As Long
Set rng = Sheets("Customer List").Range("D2:D100")
dat = rng.Value
For i = LBound(dat, 1) To UBound(dat, 1)
If dat(i, 1) <> "" Then
rng(i, -2).Value = "X"
End If
Next
End Sub
Sub Check()
Dim dat As Variant
Dim rng As Range
Dim i As Long
Set rng = Sheets("Customer List").Range("D2:D100")
dat = rng.Value
For i = LBound(dat, 1) To UBound(dat, 1)
If dat(i, 1) <> "" Then
rng(i, -2).Value = ThisWorkBook.Sheets("Order Entry").Range("B4").Value
End If
Next
End Sub
Related
This is just a sample I am testing the code in this data. I have three columns in sheet2. I have to delete the empty cells. This is the updated code which is working for column B only. You can check the snapshot
Sub delete()
Dim counter As Integer, i As Integer
counter = 0
For i = 1 To 10
If Cells(i, 1).Value <> "" Then
Cells(counter + 1, 2).Value = Cells(i, 1).Value
counter = counter + 1
End If
Next i
End Sub
Sample screenshot
If all you want is to delete the empty cells, give this a try...
Sub DeleteBlankCells()
Dim rng As Range
On Error Resume Next
Set rng = Intersect(ActiveSheet.UsedRange, Range("A:C"))
rng.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End Sub
Not the most elegant solution but it works.
Option Explicit
Sub delete()
Dim rCells As Range, rCell As Range, sFixCell As String
Set rCells = Range("A1:A13")
For Each rCell In rCells
If rCell = "" Then
sFixCell = rCell.Address
Do While rCell.Value = ""
rCell.delete Shift:=xlUp
Set rCell = Range(sFixCell)
Loop
End If
Next rCell
End Sub
I have two worksheets, "Signed" and "April". I want to copy Column "Y" from "Signed" based on certain criteria into column "A" of "April" starting from the next available/blank row. ( so right under the existing data).
My criteria for column Y is that if column L = month of cell "D2" from "April" AND the year of cell "D2" from "ApriL"...( so right now D2 is 4/30/2017).. then copy that cell in the next available row of Col A of "April" and keep adding on.
I've been trying several different things but just am not able to get it..any idea on how I can achieve this?
My code is below:
Set sourceSht = ThisWorkbook.Worksheets("Signed")
Set myRange = sourceSht.Range("Y1", Range("Y" & Rows.Count).End(xlUp))
Set ws2 = Sheets(NewSheet)
DestRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1
For Each rw In myRange.Rows
If rw.Cells(12).Value = "Month(Sheets(ws2).Range("D2"))" Then
myRange.Value.Copy Destinations:=Sheets(ws2).Range("A" & DestRow)
End If
Something like this should work for you:
Sub tgr()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim aData As Variant
Dim aResults() As Variant
Dim dtCheck As Date
Dim lCount As Long
Dim lResultIndex As Long
Dim i As Long
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Signed") 'This is your source sheet
Set wsDest = wb.Sheets("April") 'This is your destination sheet
dtCheck = wsDest.Range("D2").Value2 'This is the date you want to compare against
With wsData.Range("L1:Y" & wsData.Cells(wsData.Rows.Count, "L").End(xlUp).Row)
lCount = WorksheetFunction.CountIfs(.Resize(, 1), ">=" & DateSerial(Year(dtCheck), Month(dtCheck), 1), .Resize(, 1), "<" & DateSerial(Year(dtCheck), Month(dtCheck) + 1, 1))
If lCount = 0 Then
MsgBox "No matches found for [" & Format(dtCheck, "mmmm yyyy") & "] in column L of " & wsData.Name & Chr(10) & "Exiting Macro"
Exit Sub
Else
ReDim aResults(1 To lCount, 1 To 1)
aData = .Value
End If
End With
For i = 1 To UBound(aData, 1)
If IsDate(aData(i, 1)) Then
If Year(aData(i, 1)) = Year(dtCheck) And Month(aData(i, 1)) = Month(dtCheck) Then
lResultIndex = lResultIndex + 1
aResults(lResultIndex, 1) = aData(i, UBound(aData, 2))
End If
End If
Next i
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lCount).Value = aResults
End Sub
Alternate method using AutoFilter instead of iterating over an array:
Sub tgrFilter()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim dtCheck As Date
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Signed") 'This is your source sheet
Set wsDest = wb.Sheets("April") 'This is your destination sheet
dtCheck = wsDest.Range("D2").Value2 'This is the date you want to compare against
With wsData.Range("L1:Y" & wsData.Cells(wsData.Rows.Count, "L").End(xlUp).Row)
.AutoFilter 1, , xlFilterValues, Array(1, Format(WorksheetFunction.EoMonth(dtCheck, 0), "m/d/yyyy"))
Intersect(.Cells, .Parent.Columns("Y")).Offset(1).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
.AutoFilter
End With
End Sub
Here's a generic script which you can easily modify to handle almost ANY criteria, as needed.
Sub Copy_If_Criteria_Met()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Sheet1").Range("A1:A" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In xRg
If CStr(xCell.Value) = "X" Then
xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
xCell.EntireRow.Delete
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
So I am trying to write a For Each loop to look through an entire row. If it finds the word "Specialty" Copy it over to the next three cells.
It does this part fine, but then when it loops around, of course the next cell has "Specialty" in it bc it just copied it over. I need to figure out how to say, if you've found "Specialty" and copied it over, jump 4 cells over and begin searching again..... Tried Offsetting the active cell but didn't work.
Any ideas?
Thanks!
Sub CopySpecialtyOver()
Dim rngRow As Range
Dim Cell As Range
Set rngRow = Range("A8:BA8")
For Each Cell In rngRow
If InStr(1, Cell.Value, "Specialty") Then
Cell.Offset(0, 1).Value = Cell.Value
Cell.Offset(0, 2).Value = Cell.Value
Cell.Offset(0, 3).Value = Cell.Value
End If
Next Cell
End Sub
Here's how to loop backwards given your current code:
Sub CopySpecialtyOver()
Dim rngRow As Range
Dim Cell As Range
Dim cIndex As Long
Set rngRow = Range("A8:BA8")
For cIndex = rngRow.Columns.Count To rngRow.Column Step -1
Set Cell = Cells(rngRow.Row, cIndex)
If InStr(1, Cell.Value, "Specialty", vbTextCompare) Then
Cell.Offset(, 1).Resize(, 3).Value = Cell.Value
End If
Next cIndex
End Sub
You could replace 'For each' by a an integer iterable:
Sub CopySpecialtyOver()
Dim i As Integer
Dim rngRow As Range
Dim Cell As Range
Set rngRow = Range("A8:BA8")
For i = 1 To rngRow.Cells.Count
Set Cell = rngRow(1, i)
If InStr(1, Cell.Value, "Specialty") Then
Cell.Offset(0, 1).Value = Cell.Value
Cell.Offset(0, 2).Value = Cell.Value
Cell.Offset(0, 3).Value = Cell.Value
i = i + 3
End If
Next i
End Sub
Thank you so much! I ended up solving it like this:
Sub CopySpecialtyOver()
Dim rngRow As Range
Dim Cell As Range
Set rngRow = Range("A8:BA8")
For Each Cell In rngRow
If InStr(1, Cell.Value, "Specialty") Then
If InStr(1, Cell.Offset(0, -1).Value, "Specialty") Then
Else
Cell.Offset(0, 1).Value = Cell.Value
Cell.Offset(0, 2).Value = Cell.Value
Cell.Offset(0, 3).Value = Cell.Value
End If
End If
Next Cell
End Sub
For Each - as pointed out by other responses - may not be the best strategy. Nevertheless - as you asked for it - here comes a piece of code using some in-loop control to overcome the deficites of For Each in this use case:
Sub CopySpecialtyOver()
Dim rngRow As Range
Dim Cell As Range
Dim Found As Boolean
Dim Cnt As Integer
Set rngRow = Range("A8:BA8")
Found = False
Cnt = 0
For Each Cell In rngRow.Cells
If InStr(1, Cell.Value, "Specialty") And Not Found Then
' capture start of sequence - otherwise do nothing
Found = True
Cnt = 0
Else
If Found Then
'if in Found mode increment counter
Cnt = Cnt + 1
' expand using negative offset
If Cnt <= 3 Then
Cell = Cell.Offset(0, -Cnt).Value
End If
' break after 3rd
If Cnt = 3 Then
Found = False
Cnt = 0
End If
End If
End If
Next Cell
End Sub
This seemingly more complex code will have its advantage when run vertically (instead horizontally) over much more than just a handfull of cells, as For/Each performs much better than regular For/Next
I currently have some code that finds cells not in the first column and moves them over. I'm facing a problem with cells that start with "=". Can you guys think of any work-arounds to solve this problem. Thanks in Advance.
Sub Move()
Dim cel As Range, rng As Range
Dim wk As Worksheet
Set wk = ActiveWorkbook.ActiveSheet
Set rng = wk.UsedRange
For Each cel In rng
If cel.Value <> "" And cel.Column <> 1 Then
wk.Cells(cel.Row, 1) = cel.Value
cel.Value = ""
End If
Next cel
End Sub
Either every time in your For each loop
If Cstr(cel.Value) <> "" And ... 'you need to do that for every cel.Value occurencies
Or declare a variable at the beginning
Dim StringInCell as String
For Each cel In rng
StringInCell=Cstr(cel.Value)
If StringInCell...
You may try .Text property as well (though I haven't had luck using that ever, I rather to use CStr).
This may work as well if the parsed data is throwing an error exception or something:
...
wk.Cells(cel.Row, 1).NumberFormat = "#"
wk.Cells(cel.Row, 1) = Cstr(cel.Value) 'related to the option chosen from above
Try this
Sub Move()
Dim cel As Range, rng As Range
Dim wk As Worksheet
Set wk = ActiveWorkbook.ActiveSheet
Set rng = wk.UsedRange
For Each cel In rng
If cel.HasFormula Then
wk.Cells(cel.Row, 1).Formula = cel.Formula
cel.ClearContents
Else
If cel.Value <> "" And cel.Column <> 1 Then
With wk.Cells(cel.Row, 1)
.NumberFormat = "#" '<<edit: added formatting
.Value = cel.Value
End with
cel.Value = ""
End If
End If
Next cel
End Sub
If you have cells that begin with =, but are not to be treated as formulas, but rather as Text, then using Sgdva's alternative suggestion:
Sub Move()
Dim cel As Range, rng As Range
Dim wk As Worksheet
Set wk = ActiveWorkbook.ActiveSheet
Set rng = wk.UsedRange
For Each cel In rng
If cel.Text <> "" And cel.Column <> 1 Then
wk.Cells(cel.Row, 1) = cel.Text
cel.Value = ""
End If
Next cel
End Sub
EDIT#1:
This version should "de-formularise" a cell before moving it to column 1:
Sub Move2()
Dim cel As Range, rng As Range
Dim wk As Worksheet, s As String
Set wk = ActiveWorkbook.ActiveSheet
Set rng = wk.UsedRange
For Each cel In rng
s = cel.Text
If s <> "" And cel.Column <> 1 Then
wk.Cells(cel.Row, 1).Value = s
cel.Value = ""
End If
Next cel
End Sub
I am trying to join cells in a row if a value exists in a cell in that row.
The data has been imported from a .txt file and various sub headers are split along 2, 3 or 4 columns.
The cells cant be merged as the data will only be kept from the first cell.
The only words which are always constant are "contain" and "for" in column B.
What I've tried resembles this:
If cell.Value like "contain", or "for" then join all cells from column "A" to column "H" into column "B", align them centrally and make them bold.
thanks, in advance, for any help.
Edit Here is the code:
Sub Joining()
Dim N As Long, i As Long, r1 As Range, r2 As Range
Dim z As Long
Dim arr() As Variant
z = 1
With Activesheet
N = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
If .Cells(i, "B").Value Like "Summary*" Then
arr = .Range(.Cells(i, "A"), .Cells(i, "H")).Value
.Cells(z, "B").Value = Join(arr, " ")
z = z + 1
End If
Next i
End With
End Sub
Not sure if this is exactly what you want but it will get you close:
Sub summary()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim N As Long, i As Long, r1 As Range, r2 As Range
Dim z As Long
Dim arr() As Variant
z = 1
Set sh1 = ActiveSheet
With ActiveWorkbook
Set sh2 = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
End With
With sh1
N = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
If .Cells(i, "A").Value Like "Summary*" Then
arr = .Range(.Cells(i, "A"), .Cells(i, "H")).Value
sh2.Cells(z, "A").Value = Join(arr, " ")
z = z + 1
End If
Next i
End With
End Sub
Ok, so I've created an answer, but it ain't pretty (kinda like the whole project I've created).
It works although I'm sure there is a much simpler way of creating it.
Maybe someone can have a go at cleaning it up?
Sub SelRows()
Dim ocell As Range
Dim rng As Range
Dim r2 As Range
For Each ocell In Range("B1:B1000")
If ocell.Value Like "*contain*" Then
Set r2 = Intersect(ocell.EntireRow, Columns("A:G"))
If rng Is Nothing Then
Set rng = Intersect(ocell.EntireRow, Columns("A:G"))
Else
Set rng = Union(rng, r2)
End If
End If
Next
Call JoinAndMerge
If Not rng Is Nothing Then rng.Select
Set rng = Nothing
Set ocell = Nothing
End Sub
Private Sub JoinAndMerge()
Dim outputText As String, Rw As Range, cell As Range
delim = " "
Application.ScreenUpdating = False
For Each Rw In Selection.Rows
For Each cell In Rw.Cells
outputText = outputText & cell.Value & delim
Next cell
With Rw
.Clear
.Cells(1).Value = outputText
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
outputText = ""
Next Rw
Application.ScreenUpdating = True
End Sub