I tried several ways, but I still have a problem in my code.
What I want to do (this example in Q2 on Sheet4):
=INDEX('Sheet8'!K:K,MATCH('Sheet4'!P2,'Sheet8'!A:A,0))
I'd like to do it for all rows with content in column K on Sheet 4 so I'll probably need "For i = 1..."
What I tried:
For i = 1 To LastRowShort
row_mtch = Application.WorksheetFunction.Match(Sheet4.Cells("Q????").Value, Sheet8.Range("A1:A"), 0)
Sheet4.Range("R" & i).Value = Application.WorksheetFunction.Index(Sheet8.Range("K1:K" & LastRowShort), row_mtch)
Next i
Thanks a lot!
Andy
Entire Module:
Sub MissingBoth()
Application.ScreenUpdating = False
Dim MyRange, CopyRange As Range
Dim LastRow As Long
Dim LastRowSheet4 As Long
Dim LastRowSheet8 As Long
Set src4 = Sheet2
Set dst4 = Sheet4
LastRow = src4.Cells(Cells.Rows.Count, "D").End(xlUp).Row
LastRowSheet8 = Worksheets("Sheet8").Cells(Cells.Rows.Count, "B").End(xlUp).Row
LastRowSheet4 = Worksheets("Sheet4").Cells(Cells.Rows.Count, "K").End(xlUp).Row
src4.Unprotect
dst4.Unprotect
If src4.FilterMode = True Then
src4.ShowAllData
End If
dst4.Cells.ClearFormats
dst4.Cells.Clear
'Find content in the "Type of Rack" cells
j = 3
For i = 10 To LastRow
If src4.Cells(i, "CL").Value = "" And src4.Cells(i, "GV").Value = "" Then
src4.Cells(i, "CL").EntireRow.Copy dst4.Cells(j, 1)
j = j + 1
End If
Next i
src4.Range("A6:GW7").Copy Destination:=dst4.Range("A1:GW2")
'Copy every column EXCEPT the following
dst4.Range("GW1,CM1:GU1, U1:CK1,R1:S1,P1,J1:M1").EntireColumn.Delete
For i = 1 To LastRowSheet4
For i2 = 1 To LastRowSheet8
If Worksheets("Sheet4").Range("P" & i).Value = Worksheets("Sheet8").Range("A" & i2).Value Then
Worksheets("Sheet4").Range("Q" & i).Value = Worksheets("Sheet8").Range("K" & i2).Value
End If
Next i2
Next i
dst4.Columns("A:AX").EntireColumn.AutoFit
dst4.Rows("1:500").RowHeight = 15
dst4.Columns("N:O").Interior.Color = vbYellow
dst4.Rows("1:2").Interior.ColorIndex = 15
dst4.Range("B:I").EntireColumn.Hidden = True
Application.ScreenUpdating = True
End Sub
Have you tried something like the following code:
For i = 1 To LastRowSheet4
For i2 = 1 To LastRowSheet8
If Worksheets("Sheet4").Range("P" & i).Value = Worksheets("Sheet8").Range("A" & i2).Value Then
Worksheets("Sheet4").Range("Q" & i).Value = Worksheets("Sheet8").Range("K" & i2).Value
End If
Next i2
Next i
You will just need to define the upper ends of both sheets (LastRowSheet4 and LastRowSheet8) and this should work.
Thanks for your help. I solved the problem with recording a macro and modifying it:
Sheet4.Cells(3, 17).FormulaR1C1 = _
"=INDEX('TS-48 Matrix'!C[-7],MATCH('Missing Both'!RC[-1],'TS-48 Matrix'!C[-16],0))"
Range("Q3").AutoFill Destination:=Range("Q3:Q" & lastRowSheet4)
Related
I've tried for a while to find (search) a solution to this but can't seem to.
I'm trying to read a list from an excel document, and based on the "country" item (which is selected on another combobox) filter the list. If it is the right country I want to add the row (4 items) to the combobox row.
I can't use a array because the length changes by country, and since only the second dimension of the array can be dynamic it populates the list backwards.
I currently get this error:
Assignment to constant not permitted.
The code:
Private Sub P_Country_Change()
Dim LastR As Integer
LastR = ActiveWorkbook.Worksheets("M_DB").Range("A2", Worksheets("M_DB").Range("A2").End(xlDown)).Rows.Count
Dim j As Integer
j = 0
For i = 2 To LastR
If ActiveWorkbook.Worksheets("M_DB").Range("E" & i).Value = P_Country.Value Then
With Press_m
.AddItem = ActiveWorkbook.Worksheets("M_DB").Range("A" & i).Value
.List(j, 1) = ActiveWorkbook.Worksheets("M_DB").Range("B" & i).Value
.List(j, 2) = ActiveWorkbook.Worksheets("M_DB").Range("C" & i).Value
.List(j, 3) = ActiveWorkbook.Worksheets("M_DB").Range("D" & i).Value
End With
j = j + 1
End If
Next i
End Sub
Thanks for your help!
Ok, so I made it work. I'm not sure exactly what I did right, but to help anyone else using this as a referenace, one thing I did that may have been it was set the properties of the combobox to:
locked = False
Also I changed the code a little bit, but not so much, here it is now:
Private Sub P_Country_Change()
Dim LastR As Integer
LastR = ActiveWorkbook.Worksheets("M_DB").Range("A2", Worksheets("M_DB").Range("A2").End(xlDown)).Rows.Count
Dim j As Integer
j = 0
For s = P_m.ListCount - 1 To 0 Step -1
P_m.RemoveItem s
Next s
With P_m
.ColumnCount = 4
.ColumnWidths = "125;125;125;125"
.ColumnHeads = False
End With
For i = 2 To LastR
If ActiveWorkbook.Worksheets("M_DB").Range("E" & i).Value = Press_Country.Value Then
P_m.AddItem ActiveWorkbook.Worksheets("M_DB").Range("B" & i).Value ' Name
P_m.List(j, 1) = ActiveWorkbook.Worksheets("M_DB").Range("C" & i).Value ' Corporation
P_m.List(j, 2) = ActiveWorkbook.Worksheets("M_DB").Range("D" & i).Value ' Province
P_m.List(j, 3) = ActiveWorkbook.Worksheets("M_DB").Range("E" & i).Value ' City
j = j + 1
End If
Next i
End Sub
Finally, I found a great referance here. teach me right? RTFM first ;-)
I am trying to create a program that deletes all rows without information in columns B-G and then rearranges the data from a vertical orientation to a horizontal one.
The data is only in columns A-G arranged so that every couple rows (the number is not constant), a row of dates appears. I want every row with dates to be pasted horizontally from each other and all of the data in between the dates to move corresponding with their dates (including column A).
The part that deletes empty rows works well. However, as I tried to write the rearrangement program, I kept on getting an
"Object Required"
error that appeared in the sub line (AKA the first line). Can someone help me resolve this issue? The code is pasted below.
Sub MovingDeletion()
Set rngRange = Selection.CurrentRegion
lngNumRows = rngRange.Rows.Count
lngFirstRow = rngRange.Row
lngLastRow = lngFirstRow + lngNumRows - 1
columns("B").Select
lngCompareColumn1 = ActiveCell.Column
columns("C").Select
lngCompareColumn2 = ActiveCell.Column
columns("D").Select
lngCompareColumn3 = ActiveCell.Column
columns("E").Select
lngCompareColumn4 = ActiveCell.Column
columns("F").Select
lngCompareColumn5 = ActiveCell.Column
columns("G").Select
lngCompareColumn6 = ActiveCell.Column
columns("A").Select
lngCompareColumn7 = ActiveCell.Column
Set MedicationRow = 0
'Deletion Code (Works Fine)
For lngCurrentRow = lngLastRow To lngFirstRow Step -1
Mrow = True
If (Cells(lngCurrentRow, lngCompareColumn1).Text = "" And Cells(lngCurrentRow, lngCompareColumn2).Text = "" And Cells(lngCurrentRow, lngCompareColumn3).Text = "" And Cells(lngCurrentRow, lngCompareColumn4).Text = "" And Cells(lngCurrentRow, lngCompareColumn5).Text = "" And Cells(lngCurrentRow, lngCompareColumn6).Text = "") Then _
Rows(lngCurrentRow).Delete
'Rearrangement Code (Does not work. Gives Object Requiered error)
Dim counter As Integer
Dim NextRow As Integer
Dim i As Integer
i = lngCurrentRow
counter = 0
Number = 0
If (Cells(lngCurrentRow, lngCompareColumn7).Text <> "Days") Then
counter = counter + 1
If counter > 1 Then
NextRow = lngCurrentRow - 1
While (Cells(NextRow, lngCompareColumn7).Text <> "Days")
NextRow = NextRow - 1
Number = Number + 1
Wend
End If
Range("A" & CStr(i) & ":G" & CStr(NextRow)).Cut Range("H1" & CStr(i) & ":P" & CStr(NextRow))
End If
Next lngCurrentRow
End Sub
What I want to do is if column O contains "weekend" then change the value of column M cells to "3".
Sub weekly_weekend()
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For x = 2 To lastrow
If InStr(1, Sheet1.Range("O" & x).Value, UCase("weekend"), 1) > 0 Then
Sheet1.Range("M" & x).Value = "3"
Next x
Application.ScreenUpdating = True
End Sub
The problem with your code is that you're getting the last row of the column A, and this will prevent the For to be executed. To fix your code, you can proceed in multiple ways.
Using Range
One is to use the Range property, so you can explicitly write your column name, like this:
Sub weekly_weekend()
lastrow = Sheet1.Range("O" & Sheet1.Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For x = 2 To lastrow
If InStr(1, Sheet1.Range("O" & x).Value, UCase("weekend"), 1) > 0 Then Sheet1.Range("M" & x).Value = "3"
Next x
Application.ScreenUpdating = True
End Sub
Picking up the right column
Or you can simply pick the right number of the column you want (in this case column O is 15), like this:
Sub weekly_weekend()
lastrow = Sheet1.Cells(Sheet1.Rows.Count, 15).End(xlUp).Row
Application.ScreenUpdating = False
For x = 2 To lastrow
If InStr(1, Sheet1.Range("O" & x).Value, UCase("weekend"), 1) > 0 Then Sheet1.Range("M" & x).Value = "3"
Next x
Application.ScreenUpdating = True
End Sub
Note: Please note that if you add or remove columns, with the second method you'll need to remember to change the column index in your code accordingly.
Hope this helps.
I am running sub where it compares two cells (B and D/or string Received) from one sheet ("DATA") with two cells (C, H) from another sheet ("Incoming_report"), and if they match it transposes I, G cells from Incoming to Data.
It is done by combining two cells from Incoming_report sheet and writing new value in Z column for example "123456" from C and H to f.e. "123456Received" (there another 5 statuses (Received, Rejected, Sent...., but I need the ones only that was Received)
Then I am taking from Data Sheet B column for example 123456 and only Received (there might be another 5 statuses, but I only need the one that was received).
That makes all sence to me and works pretty good, but I have to work with more than 500k rows in each sheet. What happens - 500,000 times two cells are combined and searched in Z column in another sheet among another 500,000 for possible match, if nothing found then N/A, and then 2 combination, 3rd, 4th... till 500,000. I added the Display status bar and I see how slowly it goes (only 900 rows per minute, so for one minor mapping it would take more than 10 hours). Here is the sub itself, can anyone share ideas how to improve it to make it work faster? Thanks a million.
Sub incoming_fetch()
Application.ScreenUpdating = False
Dim incr As Long
Dim x As String
n = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
Z = Sheets("Incoming_report").Range("D" & Rows.Count).End(xlUp).Row
For i2 = 2 To Z
Sheets("Incoming_report").Range("Z" & i2).Value = Sheets("Incoming_report").Range("C" & i2).Value & Sheets("Incoming_report").Range("H" & i2).Value
Next i2
For i = 3 To n
Application.DisplayStatusBar = True
Application.StatusBar = i
x = Sheets("Data").Range("B" & i).Value & "Received"
If Sheets("Incoming_report").Range("Z:Z").Find(x, lookat:=xlWhole, LookIn:=xlFormulas) Is Nothing Then
Sheets("Data").Range("L" & i) = "N/A"
Sheets("Data").Range("M" & i) = "N/A"
Else
incr = Sheets("Incoming_report").Range("Z:Z").Find(x, lookat:=xlWhole, LookIn:=xlFormulas).Row
Sheets("DATA").Range("L" & i) = Sheets("Incoming_report").Range("I" & incr)
Sheets("DATA").Range("M" & i) = Sheets("Incoming_report").Range("G" & incr)
End If
Next i
End Sub
EDIT2: fixed source columns :
Sub incoming_fetch()
Dim i As Long, n As Long, z As Long, num As Long
Dim x As String
Dim shtIn As Worksheet, shtData As Worksheet
Dim dict As Object, arrC, arrH, arrG, arrI, v, arr, r1, r2
Dim t
Set dict = CreateObject("scripting.dictionary")
Set shtIn = Sheets("Incoming_report")
Set shtData = Sheets("Data")
n = shtData.Range("A" & Rows.Count).End(xlUp).Row
z = shtIn.Range("D" & Rows.Count).End(xlUp).Row
t = Timer
'get all values from Cols C, H, L, M
arrC = shtIn.Range(shtIn.Range("C2"), shtIn.Range("C" & z)).Value
arrH = shtIn.Range(shtIn.Range("H2"), shtIn.Range("H" & z)).Value
arrG = shtIn.Range(shtIn.Range("G2"), shtIn.Range("G" & z)).Value
arrI = shtIn.Range(shtIn.Range("I2"), shtIn.Range("I" & z)).Value
Debug.Print "Get Arrays: " & Timer - t
t = Timer
'create a lookup dictionary of all the ColC values
' (where ColH = "Received")
num = UBound(arrC, 1)
For i = 1 To num
v = arrC(i, 1)
If arrH(i, 1) = "Received" And Len(v) > 0 Then
dict(v) = Array(arrI(i, 1), arrG(i, 1))
End If
Next i
'free up some memory
Erase arrC: Erase arrH: Erase arrI: Erase arrG
Debug.Print "Filled dict: " & Timer - t
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo haveError
For i = 3 To n
If i Mod 500 = 0 Then Application.StatusBar = i
x = shtData.Range("B" & i).Value
If dict.exists(x) Then
arr = dict(x)
r1 = arr(0)
r2 = arr(1)
Else
r1 = "N/A": r2 = "N/A"
End If
With shtData
.Range("L" & i) = r1
.Range("M" & i) = r2
End With
Next i
Debug.Print "Done: " & Timer - t
haveError:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
In my worksheet some cells values are based on other cells
Info worksheet
A1: 5
B1: =A1
Design worksheet
A1:
Is there a way to copy and read the value in B1? I'm trying to use the value in a for loop, with no luck.
Sheets("Info").Select
For i = 1 to 5
If Range("B" & i).Value <> 0 Then
Range("B" & i).Copy Destination:=Sheets("Design").Range("A" & x)
'Sheets("Design").Range("A" & x).Value = Sheets("Offerte").Range("B" & i).Value
x = x + 1
End If
Next i
Your example doesn't seem to match the code well. The line
If Range("B" & i).Value = 1 Then
means that nothing will be copied in your example. It's looking for a cell with 1 in it. Why do you need that If statement at all?
EDIT I am guessing you're just checking that there's something in the cell to copy? I would probably do it this way:
If Trim(Range("B" & i).Value) <> "" Then
Also - did you miss out setting x=1?
There is more than one way to do it. One of them is using 'offset', which is a function that really worth understand. It basically points to a amount of rows / columns from the original cell.
Sub test()
Dim oCell As Excel.Range
Dim i As Integer
Dim x As Integer
Set oCell = Sheets("Info").Range("B1")
x = 1
For i = 1 To 5
If oCell.Offset(i, 0).Value = 1 Then
oCell.Offset(i, 0).Copy Destination:=Sheets("Design").Range("A" & x)
x = x + 1
End If
Next i
End Sub
Besides, you can assert the value instead of using the copy property. Notice it won't work unless x is an integer > 0.
Sub test2()
Sheets(3).Select
x = 1
For i = 1 To 5
If Range("B" & i).Value = 1 Then
Sheets(4).Range("A" & x).Value = Range("B" & i).Value
'Sheets("Design").Range("A" & x).Value = Sheets("Offerte").Range("B" & i).Value
x = x + 1
End If
Next i
End Sub