I'm trying to make a macro which calls other macros (like the one below) and applies them to specified sheets.
I think the problem is that my previously made macros in which it calls upon isn't coded correctly to be applied to sheets it's not actively on.
Here is my code:
Sub limits_Monitoring_bores()
Dim sht As Worksheet, lastRow As Long
Set sht = ActiveWorkbook.Worksheet
'Name columns appropriately
With ActiveWorkbook.Worksheets(1)
.Cells(1, 4).Value = "Min"
.Cells(1, 5).Value = "Max"
.Cells(1, 7).Value = "20th Percentile"
.Cells(1, 8).Value = "80th Percentile"
.Cells(1, 10).Value = "20th Percentile"
.Cells(1, 11).Value = "80th Percentile"
End With
lastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
sh.Range("D2:D" & lastRow).Value = "=6"
sh.Range("E2:E" & lastRow).Value = "=8.5"
sh.Range("G2:G" & lastRow).Value = "=PERCENTILE(F:F,0.2)"
sh.Range("H2:H" & lastRow).Value = "=PERCENTILE(F:F,0.8)"
sh.Range("J2:J" & lastRow).Value = "=PERCENTILE(I:I,0.2)"
sh.Range("K2:K" & lastRow).Value = "=PERCENTILE(I:I,0.8)"
Related
The table contains column G = City, H = Department and J = Date. In the columns J Date some values are missing. I want to output these rows on a new worksheet with (column A) the rownumber, (column B) the city and (column) the departement.
The code I have looks like this but in the output all rows with a value in J = Date and the output is in the columns "G, H, J". I tried to change the columns in the code but I failed.
Sub missing()
Dim ws, wsOut As Worksheet
Set ws = ActiveWorkbook.Sheets("Table1")
Set wsOut = ActiveWorkbook.Sheets("output")
lastRow = ws.Range("G" & Rows.Count).End(xlUp).Row
lastRowOut = wsOut.Range("G" & Rows.Count).End(xlUp).Row + 1
For i = 1 To lastRow
If (ws.Cells(i, 10).Value = "") _
And _
((ws.Cells(i, 7).Value = "Peking") Or _
(ws.Cells(i, 7).Value = "Tokio") Or _
(ws.Cells(i, 7).Value = "London") Or _
(ws.Cells(i, 7).Value = "Rom") Or _
(ws.Cells(i, 7).Value = "Lissabon") Or _
(ws.Cells(i, 7).Value = "Panama") Or _
(ws.Cells(i, 7).Value = "Budapest") Or _
(ws.Cells(i, 7).Value = "Prag") Or _
(ws.Cells(i, 7).Value = "Dublin") Or _
(ws.Cells(i, 7).Value = "Luxemburg")) _
And _
((ws.Cells(i, 8).Value = "A") Or _
(ws.Cells(i, 8).Value = "B") Or _
(ws.Cells(i, 8).Value = "C") Or _
(ws.Cells(i, 8).Value = "D") Or _
(ws.Cells(i, 8).Value = "E") Or _
(ws.Cells(i, 8).Value = "F") Or _
(ws.Cells(i, 8).Value = "G") Or _
(ws.Cells(i, 8).Value = "H") Or _
(ws.Cells(i, 8).Value = "I") Or _
(ws.Cells(i, 8).Value = "J")) _
Then
wsOut.Range("B" & lastRowOut & ":C" & lastRowOut).Value = ws.Range("G" & i & ":H" & i).Value
wsOut.Range("A" & lastRowOut).Value = i
lastRowOut = lastRowOut + 1
End If
Next i
End Sub
while i was writing this others have answered and honestly I like there solution but can also be done like this:
Sub missing()
Dim ws, wsOut As Worksheet
Set ws = ActiveWorkbook.Sheets("table")
Set wsOut = ActiveWorkbook.Sheets("output")
lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
lastRowOut = wsOut.Range("A" & Rows.Count).End(xlUp).Row + 1
For i = 2 To lastRow
If ws.Cells(i, 3).Value = "" Then
wsOut.Range("A" & lastRowOut & ":B" & lastRowOut).Value = ws.Range("A" & i & ":B" & i).Value
wsOut.Range("C" & lastRowOut).Value = i
lastRowOut = lastRowOut + 1
End If
Next i
End Sub
assuming table is in worksheet "table" and output is wanted in a worksheet called "output" [note output has to have a value somewhere in column A before the code is run or an error will be thrown]
Also the code you show does not appear to be trying to answer the question you've asked, it may just be that you took a wrong turn but it is quite different, let us know if we've all missed the point!
Click on cell "A1", press Ctrl+G and choose "Special", "current region" (that should select the whole array). Again press Ctrl+G and choose "Special", this type choose "Blanks".
In the address bar, type "No Date".
Press Ctrl+ENTER (don't forget the control-button).
You can record this into a macro.
Have fun :-)
Oh, by the way, this is wrong:
If Cells(i, 1).Value = "Peking" Or "Tokio" Or "London" Or ...
It should be something like:
If Cells(i, 1).Value = "Peking" Or_
Cells(i, 1).Value = "Tokio" Or_
...
(The underscore after "Or" is just to explain VBA that this should be treated as one single line.)
Not sure i'm 100% with you, but
Dim r as range
dim c as range
dim a() as variant
dim i as long
set r=range("c2:c22").specialcells(xlcelltypeblanks)
redim a(1 to r.cells.count,1)
i=1
for each c in r.cells
a(i,0) = cells(c.row,1)
a(i,1)=cells(c.row,2)
i=i+1
next c
' Output, to j1 on the same sheet.
cells(1,10).resize(ubound(a),2).value=a
I'm using this code for add new items to next blank line.
Private Sub Ekle_Butonu_Click()
Dim LastRow As Long, ws As Worksheet
Set ws = Sayfa1
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range("A" & LastRow).Value = Tarih_B
ws.Range("C" & LastRow).Value = Kaynak_B
ws.Range("E" & LastRow).Value = Aciklama_B
ws.Range("I" & LastRow).Value = Tutar_B
End Sub
And I want to print just this added line. Can you help me ?.
You need to look into the PageSetup.PrintArea property. For example:
Sub Test()
Dim lr As Long
With Sayfa1
lr = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(lr, 1).Value = Tarih_B
.Cells(lr, 3).Value = Kaynak_B
.Cells(lr, 5).Value = Aciklama_B
.Cells(lr, 9).Value = Tutar_B
.PageSetup.PrintArea = Replace("A?,C?,E?,I?", "?", lr)
.PrintOut
End With
End Sub
As per your comment, If I understand you correctly, there are more cells in that same line you want to include:
.PageSetup.PrintArea = Replace("A?:J?", "?", lr)
I'm trying to teach myself VBA (primarily in Excel 2010) and I'm stuck on some code. I've leveraged sites such as Mr. Excel, Excel is Fun, and just about everywhere else that Google takes me, but I'm not having luck finding guidance that makes sense to me.
Challenge: I have a userform that has a combobox reading a range. The issue is, the sheet that the range exists on can have multiple duplicate values, but I only want to see unique values. To make it more challenging (to me), when the User selects a value in the combobox, I want that data set to flow back to the form.
I've managed to get data back on the form, but I'm having difficulty getting the MAX "Entered Date" record. So, if there are 5 instances of the name "Tom", with "Entered Dates" of 5/1/17, 6/1/17, 7/1/17, 8/17/17, 12/1/17; I want to see the record from 12/1/17.
It appears that I need to do something with a collection to get the unique value in the combobox, but I'm not understanding how it works. I also have no clue how to tie it all to the MAX "Entered Date". Here's the code that I have so far:
Private Sub cmd_Submit_Click()
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Client Measurements")
LastRow = ws1.Range("C" & Rows.Count).End(xlUp).Row + 1
ws1.Range("B" & LastRow) = Me.txt_Updated
ws1.Range("C" & LastRow) = Me.txt_First
ws1.Range("D" & LastRow) = Me.txt_Last
ws1.Range("E" & LastRow) = Me.txt_Suffix
ws1.Range("F" & LastRow) = Me.cobo_Name
ws1.Range("G" & LastRow) = Me.txt_EntryType
ws1.Range("H" & LastRow) = Me.txt_Height
ws1.Range("I" & LastRow) = Me.txt_Weight
ws1.Range("J" & LastRow) = Me.txt_Chest
ws1.Range("K" & LastRow) = Me.txt_Hips
ws1.Range("L" & LastRow) = Me.txt_Waist
ws1.Range("M" & LastRow) = Me.txt_BicepL
ws1.Range("N" & LastRow) = Me.txt_BicepR
ws1.Range("O" & LastRow) = Me.txt_ThighL
ws1.Range("P" & LastRow) = Me.txt_ThighR
ws1.Range("Q" & LastRow) = Me.txt_CalfL
ws1.Range("R" & LastRow) = Me.txt_CalfR
End Sub
Private Sub cobo_Name_DropButtonClick()
Dim i As Long
Dim coll As Collection
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Client Measurements")
LastRow = Sheets("Client Measurements").Range("F" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Sheets("Client Measurements").Cells(i, "F").Value = (Me.cobo_Name) Or _
Sheets("Client Measurements").Cells(i, "F").Value = Val(Me.cobo_Name) Then
Me.txt_First = Sheets("Client Measurements").Cells(i, "C").Value
Me.txt_Last = Sheets("Client Measurements").Cells(i, "D").Value
Me.txt_Suffix = Sheets("Client Measurements").Cells(i, "E").Value
Me.txt_Height = Sheets("Client Measurements").Cells(i, "H").Value
Me.txt_Weight = Sheets("Client Measurements").Cells(i, "I").Value
Me.txt_Chest = Sheets("Client Measurements").Cells(i, "J").Value
Me.txt_Hips = Sheets("Client Measurements").Cells(i, "K").Value
Me.txt_Waist = Sheets("Client Measurements").Cells(i, "L").Value
Me.txt_BicepL = Sheets("Client Measurements").Cells(i, "M").Value
Me.txt_BicepR = Sheets("Client Measurements").Cells(i, "N").Value
Me.txt_ThighL = Sheets("Client Measurements").Cells(i, "O").Value
Me.txt_ThighR = Sheets("Client Measurements").Cells(i, "P").Value
Me.txt_CalfL = Sheets("Client Measurements").Cells(i, "Q").Value
Me.txt_CalfR = Sheets("Client Measurements").Cells(i, "R").Value
End If
Next
End Sub
Private Sub UserForm_Initialize()
Dim ws1 As Worksheet
Dim cCMName As Range
Set ws1 = ThisWorkbook.Sheets("Client Measurements")
For Each cCMName In ws1.Range("CMName")
With Me.cobo_Name
.AddItem cCMName.Value
End With
Next cCMName
txt_EntryType = "Check In"
End Sub
Not an exact answer to your question, but an illustration of how you might go about it. This uses a Dictionary. You add a key and item pair and update the item if the new value in B is higher than the existing item.
Sub x()
Dim vData, r As Long
vData = Range("A1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For r = 1 To UBound(vData, 1)
If vData(r, 2) > .Item(vData(r, 1)) Then
.Item(vData(r, 1)) = vData(r, 2)
End If
Next r
Range("D1").Resize(.Count) = Application.Transpose(.keys)
Range("E1").Resize(.Count) = Application.Transpose(.items)
End With
End Sub
I'll be posting a new question in a separate thread, but realized that I never marked this one as answered. Here is the code that solved my problem:
Set coboDict = CreateObject("Scripting.Dictionary")
With coboDict
For Each cStatsClientID In ws1.Range("StatsClientID")
If Not .exists(cStatsClientID.Value) Then
.Add cStatsClientID.Value, cStatsClientID.Row
Else
If CLng(cStatsClientID.Offset(, -2).Value) > CLng(ws1.Range("B" & .Item(cStatsClientID.Value))) Then
.Item(cStatsClientID.Value) = cStatsClientID.Row
End If
End If
Next cStatsClientID
Me.cobo_ClientID.List = Application.Transpose(.keys)
End With
Me again... I've got some code that copies cells from a certain column (from sheet "Convertor") and pastes it into a different column (sheet "Unallocated"). These values (IDs) are then used as a reference point to move the rest of the cells for each row (record) into the correct position I need it in.
However I can't get the code to continuously copy the IDs into a blank row so that they don't overwrite the previous set. I think it's something to do with the line Master.Cells(rowB, colB) = yourData but I can't figure it out. I tried changing the rowB to be the same xlUp to find the last unused cell in the column (as with lastA = Slave.Cells(Rows.Count, colA).End(xlUp).Row), but I couldn't get it to work. Any ideas?
Current code:
Private Sub CommandButton21_Click()
Dim colA As Integer, colB As Integer
Dim rowA As Integer, rowB As Integer
Dim Master As Worksheet, Slave As Worksheet 'declare both
Application.ScreenUpdating = False
Set Master = ThisWorkbook.Worksheets("Unallocated")
Set Slave = ThisWorkbook.Worksheets("Convertor")
colA = 17
colB = 29
rowA = 1
rowB = 1
lastA = Slave.Cells(Rows.Count, colA).End(xlUp).Row 'This finds the last row of the data of the column FROM which i'm copying
For x = rowA To lastA 'Loops through all the rows of A
yourData = Cells(x, colA)
Master.Cells(rowB, colB) = yourData
rowB = rowB + 1 'Increments the current line of destination workbook
Next x 'Skips to next row
For j = 1 To 5000 '(the master sheet)
For i = 1 To 5000 '(the slave sheet) 'for first 1000 cells
If Trim(Master.Cells(j, 29).Value2) = vbNullString Then Exit For 'if ID cell is blank exit
If Master.Cells(j, 29).Value = Slave.Cells(i, 17).Value Then
If IsEmpty(Slave.Cells(i, 3)) Then Exit Sub
Master.Cells(j, 2).Value = Slave.Cells(i, 3).Value 'Move all other data based on the ID
Master.Cells(j, 8).Value = Slave.Cells(i, 4).Value
Master.Cells(j, 9).Value = Slave.Cells(i, 5).Value
Master.Cells(j, 10).Value = Slave.Cells(i, 6).Value
Master.Cells(j, 11).Value = Slave.Cells(i, 7).Value
Master.Cells(j, 12).Value = Slave.Cells(i, 8).Value
Master.Cells(j, 13).Value = Slave.Cells(i, 9).Value
Master.Cells(j, 4).Value = Slave.Cells(i, 10).Value
Master.Cells(j, 23).Value = Slave.Cells(i, 11).Value
Master.Cells(j, 24).Value = Slave.Cells(i, 12).Value
Master.Cells(j, 25).Value = Slave.Cells(i, 13).Value
Master.Cells(j, 26).Value = Slave.Cells(i, 14).Value
Master.Cells(j, 27).Value = Slave.Cells(i, 15).Value
Master.Cells(j, 28).Value = Slave.Cells(i, 16).Value
If Not IsEmpty(Slave.Cells(i, 3)) Then _
Slave.Cells(i, 3).EntireRow.Delete 'deletes row after it has been copied
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Let's start with a simple loop copying data for each row. Then you can add in your checks.
You can use worksheet.range to write to cells (column row) such as ("A4") or ("A" & counter).
Private Sub CommandButton21_Click()
Dim ws As Excel.Worksheet
Dim wsMaster As Excel.Worksheet
Dim strValue As String
Set ws = ActiveWorkbook.Sheets("Convertor")
Set wsMaster = ActiveWorkbook.Sheets("Unallocated")
'Count of row to read from
Dim lRow As Long
lRow = 1
'Count of row to write to
Dim jRow As Long
jRow = 1
ws.Activate
'Loop through and copy what is in the rows
Do While lRow <= ws.UsedRange.Rows.count
wsMaster.Range("AC" & jRow).Value = ws.Range("Q" & lRow).Value
wsMaster.Range("B" & jRow).Value = ws.Range("C" & lRow).Value
wsMaster.Range("H" & jRow).Value = ws.Range("D" & lRow).Value
wsMaster.Range("I" & jRow).Value = ws.Range("E" & lRow).Value
wsMaster.Range("J" & jRow).Value = ws.Range("F" & lRow).Value
wsMaster.Range("K" & jRow).Value = ws.Range("G" & lRow).Value
wsMaster.Range("L" & jRow).Value = ws.Range("H" & lRow).Value
wsMaster.Range("M" & jRow).Value = ws.Range("I" & lRow).Value
wsMaster.Range("D" & jRow).Value = ws.Range("J" & lRow).Value
wsMaster.Range("W" & jRow).Value = ws.Range("K" & lRow).Value
wsMaster.Range("X" & jRow).Value = ws.Range("L" & lRow).Value
wsMaster.Range("Y" & jRow).Value = ws.Range("M" & lRow).Value
wsMaster.Range("Z" & jRow).Value = ws.Range("N" & lRow).Value
wsMaster.Range("AA" & jRow).Value = ws.Range("O" & lRow).Value
wsMaster.Range("AB" & jRow).Value = ws.Range("P" & lRow).Value
ws.Rows(lRow).EntireRow.Delete
'Increment counters for both sheets. We can actually use just one counter, but if there is ever a condition that will cause us to not copy a row, then we will need two counters.
jRow = jRow + 1
'lRow = lRow + 1 'This is commented out because we are deleting rows after we copy them.
Loop
End Sub
If you really need to delete the rows after they are copied then we will have to not increment the lRow value.
.Cells is Limiting your approach.
Consider Change to Using Range("A1:C3000") notation it's more powerful.
Range.Select
Range.Paste (to new High mark for UsedRows.Count at destination)
Also unless you have exactly 5000 rows, it's not that accurate,
experiment with
ActiveSheet.UsedRange.Rows.Count
i have several workbooks which get copy from one master workbook. what i want to do is when i enter data into the master workbook, i want to copy it into another workbook based on product type which i get fromn Combobox1.Value. to be more clear, which workbooks i want to copy the data depends on the ComboBox1.value. ie if the ComboBox1.value equals to "Penofix" then i want to copy the data into the workbook "Penofix.xlsm". i have finish coding on master input on how to enter data into particular row based on some condition but facing problem to copy the data into another workbooks.
Private Sub CmdEnter_Click()
Dim CountRow As Long
Dim i As Long
Dim prod as string
Dim j As Long
Dim Ws As Worksheet
Dim Count1 as Long
'CountRow is number of row in master workbook
CountRow = Worksheets("Input").Range("B" & Rows.Count).End(xlUp).Row
'assign variable prod with combobox1 value
prod = ComboBox1.Value
'i=32 because my row start at 32
For i = 32 To countRow + 31
While ComboBox1.Value = Worksheets("Input").Cells(i, 2).Value
Rows(i).Select
Selection.Insert shift = xlDown
With Worksheets("Input")
'insert data into master workbook
.Range("B" & i) = ComboBox1.Text
.Range("C" & i) = TextBox1.Text
.Range("D" & i) = TextBox2.Text
.Range("E" & i) = TextBox3.Text
.Range("F" & i) = TextBox4.Text
.Range("G" & i) = TextBox5.Text
.Range("H" & i) = ComboBox2.Text
.Range("I" & i) = TextBox6.Text
.Range("J" & i) = TextBox7.Text
.Range("K" & i) = TextBox8.Text
End With
'activate other workbook to copy data,if prod = Penofix,the workbook will be "Penofix.xlsm"
workbooks(prod & ".xlsm").Activate
'count the number of row in workbooks(prod & ".xlsm").
' i specified cell (31,3) to calculate the number of row used
Count1 = Workbooks(prod & ".xlsm").Worksheets("Sheet1").Cells(31,3).Value
Count1 = Count1 + 31
'copy data into workbooks(prod & ".xlsm")
'THIS IS THE LINE WHICH ERROR
Workbooks(prod & ".xlsm").Worksheets("Input").Range(Cells(Count1, 2), Cells(Count1 , 11)).Value = Workbooks("Master.xlsm").Worksheets("Input").Range(Cells(i, 2), Cells(i, 11)).Value
If MsgBox("One record written to Input. Do you want to continue entering data?", vbYesNo)= vbYes Then
ComboBox1.Text = ""
TextBox1.Text = ""
TextBox2.Text = ""
TextBox3.Text = ""
TextBox4.Text = ""
TextBox5.Text = ""
ComboBox2.Text = ""
TextBox6.Text = ""
TextBox7.Text = ""
TextBox8.Text = ""
Else
Unload Me
End If
Exit Sub
Wend
Next
End Sub
i've try to replace
Workbooks(prod & ".xlsm").Worksheets("Input").Range(Cells(Count1, 2), Cells(Count1 , 11)).Value = Workbooks("Master.xlsm").Worksheets("Input").Range(Cells(i, 2), Cells(i, 11)).Value
with this
Workbooks(prod & ".xlsm").Worksheets("Input").Cells(Count1, 2).Value = Workbooks("Master.xlsm").Worksheets("Input").Cells(i, 2).Value
and yeah its work but it just for one singe cell only. so i think the error is on the syntax :
Range(Cells(Count1,2), Cells(Count1,11))
but i dont know how to make it to copy the entire row
Workbooks("Master.xlsm").Worksheets("Input").Range(cells(i,B).cells(i,K)).Value = _
Workbooks(prod & ".xlsm").).Worksheets("Sheet1").Range(Cells(CountRow, B). Cells(CountRow, K)).Value
This code will update the master workbook, I doubt you want to this. Also there is a syntax error with .). and then some.
I think this is what you need:
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht1 = Workbooks(prod & ".xlsm").Worksheets("Sheet1")
Set sht2 = Workbooks("Master.xlsm").Worksheets("Input")
sht1.Range(sht1.Cells(CountRow, 2), sht1.Cells(CountRow, 11)).Value = _
sht2.Range(sht2.Cells(i, 2), sht2.Cells(i, 11)).Value
Imroved code: Using resize(<row>, <column>)
Workbooks(prod & ".xlsm").Worksheets("Sheet1").Cells(CountRow, 2).resize(, 11).Value = _
Workbooks("Master.xlsm").Worksheets("Input").Cells(i, 2).resize(, 11).Value
For some added info, the Cells(<Row>, <Column>) will only take integers in for either <Row> and <Column>. Hence the column B is represented as 2.