Private Sub CommandButton1_Click()
Dim nbp As Long
Dim i As Long
Dim p As Long
Dim FV As Variant
Dim CS As Variant
Dim K As Variant
Dim iFV As Integer
Dim iCS As Double
If Range("B9") = "Semi-Annual" Then
p = DateDiff("yyyy", Cells(4, 3), Cells(5, 3))
nbp = p * 2
For i = 5 To nbp + 4
Cells(5, 10).Value = Cells(4, 3).Value
Cells(i + 1, 10).Value = DateAdd("m", 6, Cells(i, 10).Value)
Next i
For i = 6 To nbp + 5
Cells(i, 14).Value = Cells(7, 2).Value * (Cells(8, 2).Value / 2)
Next i
FV = Sheet2.Range("J5:J10").Value
CS = Sheet3.Range("F1:G8000").Value
For iFV = 1 To UBound(FV)
For iCS = 1 To UBound(CS, 2)
If FV(iFV, 1) = CS(iCS, 1) Then
K(iFV, 1) = CS(iCS, 2)
End If
Next
Next
Sheet2.Range("K5:K10").Value = K
End If
End If
If Range("B9") = "Annual" Then
nbp = DateDiff("yyyy", Cells(4, 3), Cells(5, 3))
For i = 5 To nbp + 4
Cells(5, 10).Value = Cells(4, 3).Value
Cells(i + 1, 10).Value = DateAdd("m", 12, Cells(i, 10).Value)
Next i
End if
If Range("B9") = "Quarterly" Then
p = DateDiff("yyyy", Cells(4, 3), Cells(5, 3))
nbp = p * 4
For i = 5 To nbp + 4
Cells(5, 10).Value = Cells(4, 3).Value
Cells(i + 1, 10).Value = DateAdd("m", 3, Cells(i, 10).Value)
Next i
End If
If Range("B9") = "Monthly" Then ' to choose from a list .
p = DateDiff("yyyy", Cells(4, 3), Cells(5, 3))
nbp = p * 12
For i = 5 To nbp + 4
Cells(5, 10).Value = Cells(4, 3).Value
Cells(i + 1, 10).Value = DateAdd("m", 3, Cells(i, 10).Value)
Next i
End If
End Sub
I have added all the code in the button to help. i am not sure if that will help, anyway here is it. if the user chooses semi annual then couple of things take place. Same goes for the rest "ifs" but i need to fix this issue first then move on to the rest. the code to too long, it is simple and not complicated.
Now that more of the code is posted, I think I understand what the problem is.
Wherever you reference Cells() VBA assumes it applies to ActiveSheet. And I think you should fully qualify the calls to be Sheet2.Cells() for example or whatever you need.
When you call the code behind a button, the button resides on a sheet and it references the cells on that sheet. But when you moved the code to a module it no longer referenced the sheet with the button, but whatever other sheet was active at the time.
So whenever you see Cells() or Range() without a worksheet specification in front of it, change it so that it you target a specific worksheet.
PS. Avoid using Integer and prefer Long instead. Also, prefer relative referencing such as Sheet2.Range("G2").Cells(i,j) instead of absolute referencing Sheet2.Cells(1+i, 6+j) or string math such as Sheet2.Range("G" & 1+i & ":G" & 5+i).
Related
I am organizing a dirty text in an organised table. And this code stops when the cell the marked line is completed. Can you help me to make it continuing the loop?
Private Sub CommandButton1_Click()
Dim sh As Worksheet
Dim sh7 As Worksheet
Dim CNAME As String
Set sh = Worksheets("Sheet6")
Set sh7 = Worksheets("Sheet7")
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
For n = 1 To lr
If InStr(1, sh.Cells(n, 1), "CALL:") = 1 Then
CNAME = sh.Cells(n, 7).Value
Ci = sh.Cells(n + 1, 7).Value
Cpd = sh.Cells(n + 1, 7).Value
Else
If InStr(1, sh.Cells(n, 1), "Topic:") = 1 Then
T = sh.Cells(n, 2)
Tpd = sh.Cells(n + 1, 2)
Types = sh.Cells(n + 4, 2)
DM = sh.Cells(n + 5, 2)
D = sh.Cells(n + 5, 4)
OD = sh.Cells(n + 6, 2)
lr7 = sh7.Cells(Rows.Count, 1).End(xlUp).Row
sh7.Cells(lr7 + 1, 1).Value = CNAME '********This is the last line it runs.
sh7.Cells(lr7 + 1, 2).Value = Ci
sh7.Cells(lr7 + 1, 3).Value = Cpd
sh7.Cells(lr7 + 1, 4).Value = T
sh7.Cells(lr7 + 1, 5).Value = Tpd
sh7.Cells(lr7 + 1, 6).Value = Types
sh7.Cells(lr7 + 1, 7).Value = DM
sh7.Cells(lr7 + 1, 8).Value = D
sh7.Cells(lr7 + 1, 9).Value = OD
End If
End If
Next n
End Sub
You should get in the habit of defining all variables and supplying a default value.
EDIT:
It seems my original conclusion was incorrect. Upon further inspection I see what might be an issue in your code. Both times where you are trying to get the last row, you are using Rows.Count as a parameter.
Maybe change these
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
lr7 = sh7.Cells(Rows.Count, 1).End(xlUp).Row
To this (note that I use the sheet variable in the first param)
lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
lr7 = sh7.Cells(sh7.Rows.Count, 1).End(xlUp).Row
Sub blockofdatatoreport()
Dim i As Integer
Dim x As Integer
Dim y As Integer
For i = 1 To 95
actvrw = Sheet1.Range("A:A").Find(what = i, searchdirection = xlNext).Row
'searching cells top to bottom
lr = Sheet2.Range("A:A").Find(what = "*", searchdirection = xlprevious).Row + 1
'searching cells bottom to top
For x = 1 To 5
Sheet2.Cells(lr, 1).Value = Sheet1.Cells(actvrw + (x - 1), 3).Value
'looping the first five columns in sheet2
Next
For y = 1 To 4
Sheet2.Cells(lr, 5 + y).Value = Sheet1.Cells(actvrw + (y - 1), 6).Value
'looping the next four columns after the first four is done in sheet2
Next
'You can also write like this or write a loop in two lines above.
'Sheet2.Cells(lr, 1).Value = Sheet1.Cells(actvrw, 3).Value
'Sheet2.Cells(lr, 2).Value = Sheet1.Cells(actvrw + 1, 3).Value
'Sheet2.Cells(lr, 3).Value = Sheet1.Cells(actvrw + 2, 3).Value
'Sheet2.Cells(lr, 4).Value = Sheet1.Cells(actvrw + 3, 3).Value
'Sheet2.Cells(lr, 5).Value = Sheet1.Cells(actvrw + 4, 3).Value
Next
End Sub
I get error called error 13 y type mismatch, what is in the above code causing the error??
The macro below opens a series of workbooks from a list, then copies some data from them. It works fine for the first workbook, then crashes on the second. I've tried changing the order, and it's always the second workbook that causes it to crash.
Sub ImportData()
Dim lastRow As Long
Dim lastSumRow As Long
Dim j As Long
Dim k As Long
With ActiveSheet
lastRow = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
End With
For k = 2 To lastRow
k = 2
lastUsedRow = ThisWorkbook.Sheets("Summary").Cells(1048576, 1).End(xlUp).Row
If ActiveSheet.Cells(k, 2).Value <> "Imported" Then
Workbooks.Open Filename:=ThisWorkbook.Path & "\Analysis\" & Cells(k, 1), UpdateLinks:=False
ActiveWorkbook.Sheets("Summary").Activate
For j = 3 To 100
If j Mod 3 = 0 Then
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 1).Value = ActiveWorkbook.Sheets("Summary").Cells(j, 1).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 2).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 1, 2).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 3).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 1, 3).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 4).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 1, 4).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 5).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 2, 2).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 6).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 2, 3).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 7).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 2, 4).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 8).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 1, 5).Value
End If
Next j
ActiveWorkbook.Close
End If
ThisWorkbook.Sheets("Setup").Cells(k, 2).Value = "Imported"
Next k
End Sub
I'm guessing your error is here:
Workbooks.Open Filename:=ThisWorkbook.Path & "\Analysis\" & Cells(k, 1), UpdateLinks:=False
'Ooops ^^^^^
The .Activate and .Select calls are convoluted enough that I'm not really going to expend the effort figuring out what should be the active worksheet at that particular point in your code on the second run through the loop. Whatever it is, it's different than it was when you started and an unqualified call to Cells implicitly refers to whatever worksheet is the ActiveSheet at the time. This builds a bad file name (or fails completely) and then the wheels come off.
The best thing to do is not use the Active* objects at all. Get references to the objects that you're using, and well, use them. That way there is no chance that you'll get wires crossed. While you're at it, you can give them names that make it obvious what you're working with at a glance.
Couple other things before we get to the code that doesn't use Activate and Select.
lastSumRow is never used and lastUsedRow is never declared. I'm assuming they were supposed to be the same thing. You should put Option Explicit at the top of your modules to avoid this type of error (and worse ones).
These 2 lines of code make very little sense together:
For j = 3 To 100
If j Mod 3 = 0 Then
If you only want to copy every 3rd row, skip all the division and just increment your loop counter with a Step of 3:
For j = 3 To 99 Step 3
Note that you can stop at 99, because 100 Mod 3 is never going to be 0.
Your With block here isn't using the captured reference...
With ActiveSheet
lastRow = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
End With
...but you continually use this pattern that would be useful in a With block:
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 1).Value = ...
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 2).Value = ...
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 3).Value = ...
Hard-coding Cells(1048576, 1) will fail on older versions of Excel. You should use Rows.Count instead.
As mentioned in the comments, k = 2 creates an infinite loop.
You don't need to repeatedly find the last row of the sheet you're copying to with this code:
lastUsedRow = ThisWorkbook.Sheets("Summary").Cells(1048576, 1).End(xlUp).Row
Each time you go through your "j" loop, the last row increases by one. Just add 1 to lastUsedRow instead of doing all the row counting gymnastics.
If you're working with Worksheets, use the Worksheets collection instead of the Sheets collection:
ThisWorkbook.Sheets("Summary") '<--I could return a Chart!
Put all of that together, and you come up with something like the code below. Note that I have no clue what the ActiveSheet is supposed to be when you start this macro, so I just named the variable it's stored in active. It's quite possible that it's one of the other worksheets it grabs a reference too (I have no clue) - if so, you should consolidate them into one reference:
Public Sub ImportData()
Dim lastRow As Long
Dim lastUsedRow As Long
Dim dataRow As Long
Dim fileNameRow As Long
Dim active As Worksheet
Set active = ActiveSheet
With active
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Dim setupSheet As Worksheet
Set setupSheet = ThisWorkbook.Worksheets("Setup")
With ThisWorkbook.Worksheets("Summary")
lastUsedRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For fileNameRow = 2 To lastRow
If active.Cells(fileNameRow, 2).Value <> "Imported" Then
Dim source As Workbook
Set source = Workbooks.Open(ThisWorkbook.Path & "\Analysis\" & _
active.Cells(fileNameRow, 1), False)
Dim dataSheet As Worksheet
Set dataSheet = source.Worksheets("Summary")
For dataRow = 3 To 99 Step 3
.Cells(lastUsedRow, 1).Value = dataSheet.Cells(dataRow, 1).Value
.Cells(lastUsedRow, 2).Value = dataSheet.Cells(dataRow + 1, 2).Value
.Cells(lastUsedRow, 3).Value = dataSheet.Cells(dataRow + 1, 3).Value
.Cells(lastUsedRow, 4).Value = dataSheet.Cells(dataRow + 1, 4).Value
.Cells(lastUsedRow, 5).Value = dataSheet.Cells(dataRow + 2, 2).Value
.Cells(lastUsedRow, 6).Value = dataSheet.Cells(dataRow + 2, 3).Value
.Cells(lastUsedRow, 7).Value = dataSheet.Cells(dataRow + 2, 4).Value
.Cells(lastUsedRow, 8).Value = dataSheet.Cells(dataRow + 1, 5).Value
lastUsedRow = lastUsedRow + 1
Next
source.Close
End If
setupSheet.Cells(fileNameRow, 2).Value = "Imported"
Next
End With
End Sub
I want to automatically update sheet 2 & sheet 3 from sheet 1 as per data. It will be helpful if it gets resolved.
I am new to visual basic coding so unaware of its script but aware of c++. Whatever the solution may be it will be helpful.
Screen shot of the three sheets - I was unable to upload the Excel files
I have tried the following code:
Sub FindMatches()
Dim oldrow As Integer
Dim newrow As Integer
For oldrow = 4 To 14
For newrow = 3 To 20
If Cells(oldrow, 12) = Cells(1, newrow) And Cells(oldrow, 13) = Cells(newrow, 1) Then 'date and brand
If Cells(1, 14) = Cells(newrow, 2) Then
Cells(newrow, 3).Value = Cells(oldrow, 14).Value ' m1
End If
If Cells(1, 15) = Cells(newrow + 1, 2) Then
Cells(newrow + 1, 3).Value = Cells(oldrow, 15).Value ' m2
End If
If Cells(1, 16) = Cells(newrow + 2, 2) Then
Cells(newrow + 2, 3).Value = Cells(oldrow, 16).Value ' m3
End If
If Cells(1, 17) = Cells(newrow + 3, 2) Then
Cells(newrow + 3, 3).Value = Cells(oldrow, 17).Value ' issue
End If
If Cells(1, 18) = Cells(newrow + 4, 2) Then
Cells(newrow + 4, 3).Value = Cells(oldrow, 18).Value ' repack
End If
If Cells(1, 19) = Cells(newrow + 5, 2) Then
Cells(newrow + 5, 3).Value = Cells(oldrow, 19).Value ' extra
End If
If Cells(1, 20) = Cells(newrow + 6, 2) Then
Cells(newrow + 6, 3).Value = Cells(oldrow, 20).Value ' wastage
End If
End If
Next newrow
Next oldrow
End Sub
Maybe you even don't need VBA to update the data. You can simply enter a formula =C2 into a cell to reference (and retrieve the data from) a cell.
You also can reference cells from other sheets like this =Sheet1!C2.
And you can use Functions such as IF to do more complex cases and logic.
You just cant use Cells without sheet referencing. Because excel dont know which sheet you wana to use and assuming active sheet. So you need to you ActiveSheet.cells() and switching active sheet (but its not highly recommended). Instead use sheet declaration like this
Dim myLovelySheet as worksheet
Set mylovelySheet = Sheets("yourCuteSheetname")
and then you can work with sheet like with object (you will be familiar to it from C++)
myLovelySheet.cells()
or you can perform multiple operations on sheet with construction like this
with myLovelySheet
.cells()
.cells()
'etc
end with
Basicaly your approach is almost correct, but try study more code. I can recommend this which have multiple examples with good practise
I am adapting off of the question: Re-Arranging the row data in columns
I have Excel data set up as follows;
Collection LatDD LonDD Date Location Method Specie1 Specie2 Specie3(+-110 species columns in total)
ABS1 11.35 -10.3 2003-02-01 A Bucket 0 1 3
ABS2 11.36 -10.4 2003-02-02 B Stick 2 0 6
I would Like This Data to appear like so:
Collection Specie Count LatDD LonDD Date Location Method
ABS1 Specie1 11.35 -10.3 2003-02-01 A Bucket
ABS1 Specie2 1 11.35 -10.3 2003-02-01 A Bucket
ABS1 Specie3 3 11.35 -10.3 2003-02-01 A Bucket
ABS2 Specie1 2 11.36 -10.4 2003-02-02 B Stick
ABS2 Specie2 -11.36 -10.4 2003-02-02 B Stick
ABS2 Specie3 6 -11.36 -10.4 2003-02-02 B Stick
I attempted to adapt Ripsters original VBA code answer but unfortunately i was unable to figure how i would need to change it. Could someone please advise me on how to adjust his code to produce the desired output?
Here is his orginal vba code:
Sub Example()
Dim Resources() As String
Dim rng As Range
Dim row As Long
Dim col As Long
Dim x As Long
ReDim Resources(1 To (ActiveSheet.UsedRange.Rows.Count - 1) * (ActiveSheet.UsedRange.Columns.Count - 1), 1 To 3)
'Change this to the source sheet
Sheets("Sheet1").Select
'Read data into an array
For row = 2 To ActiveSheet.UsedRange.Rows.Count
For col = 2 To ActiveSheet.UsedRange.Columns.Count
x = x + 1
Resources(x, 1) = Cells(row, 1).Value ' Get name
Resources(x, 2) = Cells(1, col).Value ' Get date
Resources(x, 3) = Cells(row, col).Value ' Get value
Next
Next
'Change this to the destination sheet
Sheets("Sheet2").Select
'Write data to sheet
Range(Cells(1, 1), Cells(UBound(Resources), UBound(Resources, 2))).Value = Resources
'Insert column headers
Rows(1).Insert
Range("A1:C1").Value = Array("Resource", "Date", "Value")
'Set strings to values
Set rng = Range(Cells(1, 3), Cells(ActiveSheet.UsedRange.Rows.Count, 3))
rng.Value = rng.Value
End Sub
Try this:
Sub Example()
Dim row As Long
Dim col As Long
Dim x As Long
h1 = "Sheet1"
h2 = "Sheet2"
Sheets(h1).Select
x = 2
'Headers Sheet2
Sheets(h2).Cells(1, 1).Value = Sheets(h1).Cells(1, 1)
Sheets(h2).Cells(1, 2).Value = "Specie"
Sheets(h2).Cells(1, 3).Value = "Count"
Sheets(h2).Cells(1, 4).Value = Sheets(h1).Cells(1, 2)
Sheets(h2).Cells(1, 5).Value = Sheets(h1).Cells(1, 3)
Sheets(h2).Cells(1, 6).Value = Sheets(h1).Cells(1, 4)
Sheets(h2).Cells(1, 7).Value = Sheets(h1).Cells(1, 5)
Sheets(h2).Cells(1, 8).Value = Sheets(h1).Cells(1, 6)
For row = 2 To ActiveSheet.UsedRange.Rows.Count
For col = 7 To ActiveSheet.UsedRange.Columns.Count
Sheets(h2).Cells(x, 1).Value = Sheets(h1).Cells(row, 1).Value
Sheets(h2).Cells(x, 2).Value = Sheets(h1).Cells(1, col).Value
Sheets(h2).Cells(x, 3).Value = Sheets(h1).Cells(row, col).Value
Sheets(h2).Cells(x, 4).Value = Sheets(h1).Cells(row, 2).Value
Sheets(h2).Cells(x, 5).Value = Sheets(h1).Cells(row, 3).Value
Sheets(h2).Cells(x, 6).Value = Sheets(h1).Cells(row, 4).Value
Sheets(h2).Cells(x, 7).Value = Sheets(h1).Cells(row, 5).Value
Sheets(h2).Cells(x, 8).Value = Sheets(h1).Cells(row, 6).Value
x = x + 1
Next
Next
End Sub
Sheet1:
Sheet2:
A short versiĆ³n:
Sub Example()
Dim row As Long
Dim col As Long
Dim x As Long
Set Sh1 = ThisWorkbook.Worksheets("Sheet1")
Set Sh2 = ThisWorkbook.Worksheets("Sheet2")
Sh1.Select
'Headers Sheet2
Sh2.Cells(1, 1).Value = Sh1.Cells(1, 1)
Sh2.Cells(1, 2).Value = "Specie"
Sh2.Cells(1, 3).Value = "Count"
For i = 4 To 8
Sh2.Cells(1, i).Value = Sh1.Cells(1, i - 2)
Next
x = 2 'Starting row of sheet2.
For row = 2 To ActiveSheet.UsedRange.Rows.Count
For col = 7 To ActiveSheet.UsedRange.Columns.Count
Sh2.Cells(x, 1).Value = Sh1.Cells(row, 1).Value
Sh2.Cells(x, 2).Value = Sh1.Cells(1, col).Value
Sh2.Cells(x, 3).Value = Sh1.Cells(row, col).Value
For i = 4 To 8
Sh2.Cells(x, i).Value = Sh1.Cells(row, i - 2).Value
Next
x = x + 1
Next
Next
Sh2.Select
End Sub
another idea....
Your source data is in "Sheet1", starting at "A1", no empty values neither in Column A, nor in Row 1.
If you run the code, you will get the re-sorted table in "Sheet2" ( I omitted headers, though - too lazy....)
Hope this helps
Sub sort_new()
Dim col_no As Long, row_no As Long
Dim i As Long, j As Long, k As Long
Dim arr_DB As Variant, arr_new As Variant
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
ws1.Activate
row_no = ws1.Range(Cells(Rows.Count, 1), Cells(Rows.Count, 1)).End(xlUp).Row
col_no = ws1.Range(Cells(1, Columns.Count), Cells(1, Columns.Count)).End(xlToLeft).Column
arr_DB = ws1.Range(Cells(1, 1), Cells(row_no, col_no))
ReDim arr_new(1 To (row_no - 1) * (col_no - 6), 1 To 8)
For i = 2 To row_no
For j = 7 To col_no
k = k + 1
arr_new(k, 1) = arr_DB(i, 1) 'Collection
arr_new(k, 4) = arr_DB(i, 2) 'LatDD
arr_new(k, 5) = arr_DB(i, 3) 'LonDD
arr_new(k, 6) = arr_DB(i, 4) 'Date
arr_new(k, 7) = arr_DB(i, 5) 'Location
arr_new(k, 8) = arr_DB(i, 6) 'Method
arr_new(k, 2) = arr_DB(1, j) 'Each Specie(j) Column
arr_new(k, 3) = arr_DB(i, j) 'Each Specie(j) Column
Next
Next
ws2.Activate
ws2.Range(Cells(2, 1), Cells((row_no - 1) * (col_no - 6) + 1, 8)) = arr_new
End Sub