I’m starting with a worksheet “Med” that has formulas/data/formatting in cells A4:P9. I need to copy those cells to cell A10 (6 rows down). I then need to fill in some of the cells from information in another worksheet “Data”. I need to repeat this the same number of times as the count of Data!(A:A) -1 dropping down 6 rows each time I copy the information.
The data that I need to fill in comes from the Sheet "Data" and moves over one column for each copy in Sheet “Med”.
I have the code to make the first copy, but don’t have any idea where to go from here. Looking at the code below the next copy would go to A16 (6 rows down from A10).
The ranges from the worksheet “Med” would also increase by 6 rows and the columns would stay the same.
The ranges from the worksheet “Data” would move over on column and the row numbers would stay the same.
Jordan
Sub Macro1()
Dim wsData As Worksheet
Dim wsMed As Worksheet
Set wsData = Sheets("Data")
Set wsMed = Sheets("Med")
'Copy data set
wsMed.Range("A4:P9").Copy wsMed.Range("A10") 'Set Premium Values
wsMed.Range("M11").Value = wsData.Range("C20").Value
wsMed.Range("M12").Value = wsData.Range("C21").Value
wsMed.Range("M13").Value = wsData.Range("C22").Value
wsMed.Range("M14").Value = wsData.Range("C23").Value 'Set Assumptions
wsMed.Range("L11").Value = wsData.Range("C24").Value
wsMed.Range("L12").Value = wsData.Range("C25").Value
wsMed.Range("L13").Value = wsData.Range("C26").Value
wsMed.Range("L14").Value = wsData.Range("C27").Value
End Sub
This macro runs the code three times
Sub Macro1()
Dim wsData As Worksheet
Dim wsMed As Worksheet
Set wsData = Sheets("Data")
Set wsMed = Sheets("Med")
Dim i As Integer, j As Integer, x As Integer
i = 10
j = 3
'Copy data set
For x = 1 To 3 ' run 3 times
wsMed.Range("A4:P9").Copy wsMed.Cells(i, 1) 'Set Premium Values
wsMed.Range("M" & i + 1).Value = wsData.Cells(20, j).Value
wsMed.Range("M" & i + 2).Value = wsData.Cells(21, j).Value
wsMed.Range("M" & i + 3).Value = wsData.Cells(22, j).Value
wsMed.Range("M" & i + 4).Value = wsData.Cells(23, j).Value 'Set Assumptions
wsMed.Range("L" & i + 1).Value = wsData.Cells(24, j).Value
wsMed.Range("L" & i + 2).Value = wsData.Cells(25, j).Value
wsMed.Range("L" & i + 3).Value = wsData.Cells(26, j).Value
wsMed.Range("L" & i + 4).Value = wsData.Cells(27, j).Value
i = i + 6
j = j + 1
Next x
End Sub
Related
I'm using an Index to loop through non blank records in another worksheet and pull through 2 values which works fine.
I now need to duplicate these rows so each row appears 4 times with a 3rd column containing the 4 company names (Company1, Commpany2, Company3 and Company4).
We therefore end up with 4 times the number of records as the source sheet which should look like the following:
My current code is:
Sub Address_Raw()
Dim dataBook As Workbook
Dim Address_Raw As Worksheet, Del_Tax As Worksheet
Dim dataSource As Range, dataDest As Range
Dim sourceDataRowCount As Integer, index As Integer
Set dataBook = Application.ThisWorkbook
Set sheetSource = dataBook.Sheets("Address_Raw")
Set sheetDest = dataBook.Sheets("Del_Tax")
Set dataSource = sheetSource.Range("B4", _
sheetSource.Range("B90000").End(xlUp))
sourceDataRowCount = dataSource.Rows.Count
Set dataDest = sheetDest.Range("B13", "B" & _
sourceDataRowCount)
For index = 1 To sourceDataRowCount
dataDest(index, 1).Value = dataSource(index, 1).Value
dataDest(index, 2).Value = dataSource(index, 2).Value
Next index
End Sub
You will have to add an inner loop in the for loop. Something like this (untested):
destIndex = 1
For index = 1 To sourceDataRowCount
For j = 1 to 4
dataDest(destIndex, 1).Value = dataSource(index, 1).Value
dataDest(destIndex, 2).Value = dataSource(index, j + 1).Value
destIndex = destIndex + 1
Next j
Next index
I'm writing an excel VBA script to loop through a set of 4 sheets, find a string at the top of a column of data, loop through all the data in that column and print the header and data in a summary tab.
I'm new to VBA and even after extensive research can't figure out why I'm getting Runtime error 1004 "Application-defined or object-defined error."
Here is the VBA code:
Private Sub CommandButton1_Click()
Dim HeaderList(1 To 4) As String, sheet As Worksheet, i As Integer, j As Integer, Summary As Worksheet
'Define headers to look for
HeaderList(1) = "Bananas"
HeaderList(2) = "Puppies"
HeaderList(3) = "Tigers"
'Loop through each sheet looking for the right header
For Each sheet In Workbooks("Tab Extraction Test.xlsm").Worksheets
i = i + 1
'Debug.Print i
'Debug.Print HeaderList(i)
Set h = Cells.Find(What:=HeaderList(i))
With Worksheets("Summary")
Worksheets("Summary").Cells(1, i).Value = h
End With
Col = h.Column
Debug.Print Col
Row = h.Row
Debug.Print Row
j = Row
'Until an empty cell in encountered copy the value to a summary tab
Do While IsEmpty(Cells(Col, j)) = False
j = j + 1
V = Range(Col, j).Value
Debug.Print V
Workbooks("Tab Extraction Test.xlsm").Worksheets("Summary").Cells(j, i).Value = V
Loop
Next sheet
End Sub
The error occurs at
Worksheets("Summary").Cells(1, i).Value = h
From other posts I thought this might be because I was trying to add something to a different cell than the one that was active in the current loop so I added a With statement but to no avail.
Thank you in advance for your help.
Following the comments above, try the code below.
Note: I think your Cells(Row, Col) is mixed-up, I haven't modified it yet in my answer below. I think Cells(Col, j) should be Cells(j, Col) , no ?
Code
Option Explicit
Private Sub CommandButton1_Click()
Dim HeaderList(1 To 4) As String, ws As Worksheet, i As Long, j As Long, Summary As Worksheet
Dim h As Range, Col As Long
'Define headers to look for
HeaderList(1) = "Bananas"
HeaderList(2) = "Puppies"
HeaderList(3) = "Tigers"
' set the "Summary" tab worksheet
Set Summary = Workbooks("Tab Extraction Test.xlsm").Worksheets("Summary")
'Loop through each sheet looking for the right header
For Each ws In Workbooks("Tab Extraction Test.xlsm").Worksheets
With ws
i = i + 1
Set h = .Cells.Find(What:=HeaderList(i))
If Not h Is Nothing Then ' successful find
Summary.Cells(1, i).Value = h.Value
j = h.Row
'Until an empty cell in encountered copy the value to "Summary" tab
' Do While Not IsEmpty(.Cells(h.Column, j))
Do While Not IsEmpty(.Cells(j, h.Column)) ' <-- should be
j = j + 1
Summary.Cells(j, i).Value = .Cells(j, h.Column).Value
Loop
Set h = Nothing ' reset range object
End If
End With
Next ws
End Sub
Try this one.
Private Sub CommandButton1_Click()
Dim HeaderList As Variant, ws As Worksheet, i As Integer, j As Integer, Summary As Worksheet
Dim lastRow As Long, lastCol As Long, colNum As Long
HeaderList = Array("Bananas", "Puppies", "Tigers", "Lions")
For Each ws In Workbooks("Tab Extraction Test.xlsm").Worksheets
lastCol = ws.Range("IV1").End(xlToLeft).Column
For k = 1 To lastCol
For i = 0 To 3
Set h = ws.Range(Chr(k + 64) & "1").Find(What:=HeaderList(i))
If Not h Is Nothing Then
lastRow = ws.Range(Chr(h.Column + 64) & "65536").End(xlUp).Row
colNum = colNum + 1
' The below line of code adds a header to summary page (row 1) showing which workbook and sheet the data came from
' If you want to use it then make sure you change the end of the follpowing line of code from "1" to "2"
' ThisWorkbook.Worksheets("Summary").Range(Chr(colNum + 64) & "1").Value = Left(ws.Parent.Name, Len(ws.Parent.Name) - 5) & ", " & ws.Name
ws.Range(Chr(h.Column + 64) & "1:" & Chr(h.Column + 64) & lastRow).Copy Destination:=ThisWorkbook.Worksheets("Summary").Range(Chr(colNum + 64) & "1")
Exit For
End If
Next i
Next k
Next ws
End Sub
Sometimes you have to remove blank sheets. Say you have 2k sheets because you combined a bunch of txt files into one workbook. But they're all in one column. So you loop through to do a text2columns. It does some of them but not all of them. It stops to give you run-time error 1004. Try removing blank sheets before looping through to do text2columns or something else.
Sub RemoveBlankSheets_ActiveWorkbook()
'PURPOSE: Delete any blanks sheets in the active workbook
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim sht As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In ActiveWorkbook.Worksheets
If WorksheetFunction.CountA(sht.Cells) = 0 And _
ActiveWorkbook.Sheets.Count > 1 Then sht.Delete
Next sht
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have a userform where the user inputs data and then clicks the button Add.
The VBA then creates a new row and inputs the data from the user into that row.
This works fine, however I want to also add a new row in a different sheet as well and this is where I am stuck.
This is my code:
Dim i As String
Dim j As String
Dim k As String
Dim m As String
Dim n As String
j = XIDBox.Value
i = OrgNameBox.Value
k = ContactNameBox.Value
m = PhoneBox.Value
n = EmailBox.Value
dstRw = Sheets("Input Data").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Input Data").Cells(dstRw, 1).Value = i
Sheets("Input Data").Cells(dstRw, 2).Value = j
Sheets("Input Data").Cells(dstRw, 4).Value = k
Sheets("Input Data").Cells(dstRw, 6).Value = m
Sheets("Input Data").Cells(dstRw, 5).Value = n
'Here I want a code that inserts a blank row just as dstRw does above but in a different sheet.
The process is very similar to what you have in place.
'Here I want a code that inserts a blank row just as dstRw does above but in a different sheet.
Dim otherSheet As Worksheet
Set otherSheet = Sheets("Other Sheet Name")
' Insert as the last row.
Dim otherRow As Long
otherRow = otherSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
' Now write the values.
otherSheet.Cells(otherRow, 1).Value = i
otherSheet.Cells(otherRow, 2).Value = j
otherSheet.Cells(otherRow, 4).Value = k
otherSheet.Cells(otherRow, 6).Value = m
otherSheet.Cells(otherRow, 5).Value = n
This works for both sheets using an array for your sheets. You can expand it by adding items to the array in the same manner. You also don't need to store the values as variables, since the name of the object is small, you can just set the cell's values directly from the source.
This finds the last row for each sheet, adds 1 and then sets the values of the cells from your source objects. Then loops the process for the next sheet in the array.
TESTED:
Sub ValueMove()
Dim dstRw As Long
Dim sheet(1) As String
sheet(0) = "Input Data"
sheet(1) = "Different Sheet"
For s = 0 To 1
dstRw = Sheets(sheet(s)).Range("A" & Rows.count).End(xlUp).row + 1
Sheets(sheet(s)).Cells(dstRw, 1).Value = OrgNameBox.Value
Sheets(sheet(s)).Cells(dstRw, 2).Value = XIDBox.Value
Sheets(sheet(s)).Cells(dstRw, 4).Value = ContactNameBox.Value
Sheets(sheet(s)).Cells(dstRw, 6).Value = PhoneBox.Value
Sheets(sheet(s)).Cells(dstRw, 5).Value = EmailBox.Value
Next s
End Sub
I'm new to VBA, and I've been trying to paste some data from one file into my active file. Unfortunately, I've been getting error 13 - Type Mismatch. I've tried changing each of the variable definitions, even declaring them as Variant, but nothing helped. The most relevant part of the code is below, with the error between the asterisks.
dim i, j, k, CompShtStartNum, CompShtQty as integer
dim OldFile as variant
dim WCompWS, WCOl, NumEntryCol, ShtName as string
dim InputsSht as worksheet
dim NumEntryColRange, OldEntryCount as range
'Paste data from Entry Label columns into comparison sheets
'Paste in the data from the old file
For i = CompShtStartNum To CompShtStartNum + CompShtQty - 1
ShtName = ThisWorkbook.Sheets(i).Name
Set OldSht = OldFile.Sheets(ShtName)
Set OldEntryCount = Range(OldSht.Cells(2, 1), OldSht.Cells(Rows.Count, 1).End(xlDown))
For j = 1 To CompShtStartNum - i + 1
For k = 1 To InputsSht.Range(WCol & 12 + j - 1).Value
If OldFile.Sheets(i).Cells(1, k).Value = Sheets(i).Cells(1, k).Value Then
***Sheets(i).Cells(2, k).Resize(OldEntryCount.Rows.Count, 1).Value = Application.Transpose(OldEntryCount.Value)***
End If
Next k
Next j
Next i
For context, here is the full code:
Set OldFile = Application.Workbooks("Old Input File.xlsx")
Let WCompWS = "E"
Let WCol = "F"
Let CompShtStartNum = 2
Set InputsSht = ThisWorkbook.Sheets("Inputs")
Let CompShtQty = InputsSht.Range(WCompWS & 12, InputsSht.Range(WCompWS & 12).End(xlDown)).Count
'Loop thru each sheet and have the user determine the last column of labels. Paste result on Inputs sheet.
For i = CompShtStartNum To CompShtStartNum + CompShtQty - 1
ShtName = ThisWorkbook.Sheets(i).Name
Sheets(ShtName).Activate
NumEntryCol = Application.InputBox("How many columns (from the left-hand side) contain entry labels?" & vbNewLine & "(Examples of entry labels: Library #, Entry #, etc.)" & vbNewLine & vbNewLine & "Please type your answer numerically.", ShtName)
InputsSht.Range(WCol & 12 + i - CompShtStartNum).Value = NumEntryCol
Next i
Set NumEntryColRange = InputsSht.Range(WCol & 12, InputsSht.Range(WCol & 12).End(xlDown))
InputsSht.Activate
'Paste data from Entry Label columns into comparison sheets
'Paste in the data from the old file
For i = CompShtStartNum To CompShtStartNum + CompShtQty - 1
ShtName = ThisWorkbook.Sheets(i).Name
Set OldSht = OldFile.Sheets(ShtName)
Set OldEntryCount = Range(OldSht.Cells(2, 1), OldSht.Cells(Rows.Count, 1).End(xlDown))
For j = 1 To CompShtStartNum - i + 1
For k = 1 To InputsSht.Range(WCol & 12 + j - 1).Value
If OldFile.Sheets(i).Cells(1, k).Value = Sheets(i).Cells(1, k).Value Then
***Sheets(i).Cells(2, k).Resize(OldEntryCount.Rows.Count, 1).Value = Application.Transpose(OldEntryCount.Value)***
End If
Next k
Next j
Next i
Any help or suggestions would be very appreciated!!
However, the result was only the value in A2 being pasted into A2:A7 on the active file sheet. How can I get each of the values in A2:A7 to paste into their respective cells on my active sheet?
Try this
Sheets(i).Cells(2, k).Resize(OldEntryCount.Rows.Count, 1).Value = _
OldEntryCount.Value
Here is a short demonstration. Let's say our worksheet looks like this
Now lets say we want the values of A1:A5 in B1:B5 in Sheet1
Simply try this
Sub Sample()
Dim OldEntryCount As Range
With ThisWorkbook.Sheets("Sheet1")
Set OldEntryCount = .Range("A1:A5")
.Range("B1").Resize(OldEntryCount.Rows.Count, 1).Value = _
OldEntryCount.Value
End With
End Sub
And you will get the result
I have 3 issues with the following piece of code:
Intention of code: I have a table of data, 4 columns (F,G, H and I) wide and X rows long (X is typically between 5 and 400). I have a list of dates in column M, typically no more than 8 dates. Column H of table, contains dates as well. I want to find the dates that are in both columns (H and M) and whenever they appear, go to the same row in column I and set its value to zero, and the one after it (so if a match was in H100, then I100 and I101 would be zeroed).
issues with code: edited 1) as per feedback.
1) I have, using an if formula (=if(H100=M12,1,0), verified that there is one match, as how the spreadsheet sees it. The macro does not find this match, despite confirmation from the if formula. Cells I100 and I101 have nonzero values, when they should be zeroed.
2) the code runs, but takes about 3 minutes to go through 3 sheets of 180 rows of data. What can be done to make it run faster and more efficiently? It could have up to 30 sheets of data, and 400 rows (extreme example but possible, in this instance im happy to let it run a bit).
3) Assuming my data table before the macro is run, is 100 rows long, starting in row 12, after the macro, column I has nonzero values for 111 rows, and zeroes for the next 389. Is there a way I can prevent it from filling down zeroes, and leaving it blank?
I am using a correlate function afterwards on column I and there huge agreement of 0's with 0's is distorting this significantly. Thanks in advance,
Sub DeleteCells()
Dim ws As Worksheet
Dim cell As Range, search_cell As Range
Dim i As Long
Dim h As Long
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then
For Each cell In ws.Range("H12:H500")
On Error Resume Next
h = ws.Range("G" & Rows.Count).End(xlUp).Row
i = ws.Range("L" & Rows.Count).End(xlUp).Row
Set search_cell = ws.Range("M12:M" & h).Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole)
On Error GoTo 0
If Not search_cell Is Nothing Then
ws.Range("I" & cell.Row).Value = 0
ws.Range("I" & cell.Row + 1).Value = 0
Set search_cell = Nothing
End If
Next cell
End If
Next ws
Application.ScreenUpdating = True
Set ws = Nothing: Set cell = Nothing: Set search_cell = Nothing
End Sub
EDIT: TESTED CODE, will work for 0, 1 row of data in H/M column starting from row 12?
EDIT: Updated the cell to handle case with 1 line of data, untested :|
I will give my solution first, this one should be much faster because it read the cells into memory first
Please comment if it doesn't work or you have further question
Sub DeleteCells()
Dim ws As Worksheet
Dim i As Long
Dim h As Long
Dim MColumn As Variant ' for convinence
Dim HColumn As Variant
Dim IColumn As Variant
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then 'matching the target sheet
' matching the rows where column M's date matches column H's date
'starting row num is 12
With ws ' for simplifying the code
h = .Range("H" & .Rows.count).End(xlUp).Row
If h = 12 Then ' CASE for 1 row only
If Range("H12").Value = Range("M12").Value Then
Range("I12:I13").Value = ""
End If
ElseIf h < 12 Then
' do nothing
Else
ReDim HColumn(1 To h - 11, 1 To 1)
ReDim MColumn(1 To h - 11, 1 To 1)
ReDim IColumn(1 To h - 10, 1 To 1)
' copying the data from worksheet into 2D arrays
HColumn = .Range("H12:H" & h).Value
MColumn = .Range("M12:M" & h).Value
IColumn = .Range("I12:I" & h + 1).Value
For i = LBound(HColumn, 1) To UBound(HColumn, 1)
If Not IsEmpty(HColumn(i, 1)) And Not IsEmpty(MColumn(i, 1)) Then
If HColumn(i, 1) = MColumn(i, 1) Then
IColumn(i, 1) = ""
IColumn(i + 1, 1) = ""
End If
End If
Next i
'assigning back to worksheet cells
.Range("H12:H" & h).Value = HColumn
.Range("M12:M" & h).Value = MColumn
.Range("I12:I" & h + 1).Value = IColumn
End If
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub