Help with VBA macro

[Allison1995]

Hello everyone!

First of all I have to say is a great forum! found really interesting stuff that helped me with my VBA skills.

Secondly, I was wondering if someone could help me with a simple macro that I couldn't find online and is driving me crazy.

What I have is a table with different times on the first column starting at A5 :e.g 0.01hr, 0.023 hr, 0.011 hr, 0.18 hr, 0.205 hr etc. and different values in the rest.

This is really big matrix that goes up to 180 hours, what I'm trying to do is ;

-Look at the times from A5 to the last number of the column.
-Choose a time interval e.g. every 10 min.
-Select the row that are closer to that time interval (this will be, close to 0.1, 0.2 0.3hr .....). This will have to compare the previous and next number between 10, for example 9.1 and 10.2 . Whatever number is closer to 10, is the row I want to select.
-Move to the next interval (0.2hr min) and do the same until it has finish to the last interval (e.g. 200hr)
-Copy that rows closes to my time intervals and paste them into Sheet4.

I don't think I'm doing this the easy way. What I try is creating a column with my times that I want to select. e.g. 10, 20, 30, 40 .... ("D"). Then used the Match function to select the row with the time closes to the one I set, and them used INDEX, to see the value, copy it and paste it.

Sub CreateSheet()
'this creates the new sheet4 where the data will be pasted.

With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Sheet4"
End With

Worksheets("Sheet2").Range("G6:G7000").Formula = "=(=MATCH(MIN(ABS(A$1:A$36-D4)),ABS(A$1:A$36-D4),0))"

Worksheets("Sheet2").Range("G6:G7000").Formula = "=(=INDEX(B$1:C$36,MATCH(MIN(ABS(A$1:A$36-D1)),ABS(A$1:A$36-D1),0),0))"
Worksheets("Sheet2").Range("G6:G7000").Formula = "=(=INDEX(B$1:C$36,MATCH(MIN(ABS(A$1:A$36-D1)),ABS(A$1:A$36-D1),0),0))"

Sheets("Sheet2").Rows("5").EntireRow.Copy
Sheets("Sheet4").Rows("2").PasteSpecial xlPasteValues

End Sub

Will be great if anyone could give me a hand or give me some guidance .

Thank you in advance, much appreciated it

(P.S. I'm new to the forum and couldn't find it anywhere)

 

[tonyyy]

Allison1995,

Welcome to the Board.

It would help quite a bit if you could post sample data. (Please see the link in my signature on how to post Excel data.)

Cheers,

tonyyy

 

[Peter_SSs]

Welcome to the Mrexcel board!

I'm not quite sure exactly what your column A data looks like but see if this gets you going in the right direction.
For this sample data, and looking for multiples of 10 (see 'Const' line in the code below), the code copies the green rows to Sheet4.
I have assumed
- this data sheet is the active sheet when the code is run
- there is a header row in row 4 that can be used to determine the extent of columns of data
- column A is sorted smallest to largest

Post back with more details and sample data as requested by Tony if this is not what you need.

Excel 2016
	A	B	C	D
4	Hdr 1	Hdr 2	Hdr 3	Hdr 4
5	1.3	17	59	7
6	4.2	74	6	42
7	5.6	56	26	67
8	8.2	71	62	74
9	9.3	50	95	96
10	9.9	43	43	30
11	11.3	34	30	4
12	13.5	20	88	100
13	14.5	92	8	37
14	16.6	80	92	94
15	18.8	17	10	72
16	18.9	93	13	67
17	19.2	56	90	100
18	19.4	52	44	9
19	19.8	86	78	86
20	21.5	17	54	4
21	21.7	55	96	49
22	22.7	51	97	21
23	23.5	92	69	20
24	24.3	98	6	82
25	25.2	89	81	34
26	26.5	91	74	51
27	27.3	48	83	43
28	28.8	37	64	58
29	30.4	59	46	82
30	30.7	78	89	76
31	33.1	90	2	57
32	33.5	47	100	7
33	35	73	7	47
34	35.5	4	77	47
35	36	62	10	79
36	37.6	51	11	60
37	38.3	44	45	11
38	38.7	3	57	68
39	39	22	24	55
40	39.1	73	47	6
41	42.4	61	41	68
Sheet1

Sub Sample_Rows()
  Dim a As Variant, b As Variant
  Dim i As Long, nc As Long
  Dim dTest As Double
  
  Const Interval As Double = 10
  
  With Range("A4", Range("A" & Rows.Count).End(xlUp).Offset(1)).Resize(, Cells(4, Columns.Count).End(xlToLeft).Column)
    nc = .Columns.Count + 1
    a = .Columns(1).Value
    a(1, 1) = a(2, 1)
    ReDim b(1 To UBound(a), 1 To 1)
    b(1, 1) = 1
    dTest = Interval
    For i = 2 To UBound(a)
      If Int(a(i, 1) / dTest) > Int(a(i - 1, 1) / dTest) Then
        b(IIf(Abs(a(i, 1) - dTest) > Abs(a(i - 1, 1) - dTest), i - 1, i), 1) = 1
        dTest = dTest + Interval
      End If
    Next i
    .Columns(nc).Value = b
    Intersect(.EntireColumn, .Columns(nc).SpecialCells(xlConstants).EntireRow).Copy Destination:=Sheets("Sheet4").Range("A1")
    .Columns(nc).ClearContents
  End With
End Sub

 

[Allison1995]

Hello Peter!

Thank you very much, this is exactly what I needed, you are a champion!.

I did get it to work with Matlab but was struggling with VBA. One last questions, will it be possible to also record and paste the first value ? (this is the one close to 0)

Much appreciated it!.

Allison

 

[Allison1995]

Hi Peter,

Please see attached the overall code. I'm getting and error Run-time error '13': Type mismatch. Apparently is because I have another variable with the same name but can't find it. If I ran just your code without anything else, works perfectly.

Sub CreateSheet()
'create the different sheets I will work with
    With ThisWorkbook
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Sheet2"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Sheet3"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Sheet4"
    End With
    
 'loads the data from the sheets, and close the workbooks
 'first workbook
    
Workbooks.Open Filename:="C:\Users\admin\Desktop\Excel\1.xlsx"
ActiveSheet.Name = "1"

Workbooks("1").Sheets(1).UsedRange.Copy Destination:=Workbooks("ThisWorkbook").Sheets(2).Range("A1")

ActiveWorkbook.Close False
 
Workbooks.Open Filename:="C:\Users\admin\Desktop\Excel\2.xlsx"
ActiveSheet.Name = "1"

'second workbook
Workbooks("2").Sheets(1).UsedRange.Copy Destination:=Workbooks("ThisWorkbook").Sheets(3).Range("A1")
ActiveWorkbook.Close False

'Operates woksheets 3
Worksheets("Sheet3").Range("B2").Delete
Worksheets("Sheet3").Range("O2").Formula = "=((SUM('Sheet3'!B:B))/60000)"
Worksheets("Sheet3").Range("P2").Formula = "=((SUM('Sheet3'!F:F))/60000)"
Sheets("Sheet3").Range("O2").Copy
Sheets("Sheet1").Range("D2").PasteSpecial xlPasteValues

'Operates woksheets 2
Sheets("Sheet2").Range("G1").EntireColumn.Insert
Worksheets("Sheet2").Range("G5").Formula = "=F5"
Worksheets("Sheet2").Range("G6:G7000").Formula = "=(G5+F6)"

'Looks for the values closes to 0.1 and pastes them into sheet 4

  Dim a As Variant, b As Variant
  Dim i As Long, nc As Long
  Dim dTest As Double
  
  Const Interval As Double = 0.1
  
  With Range("A4", Range("A" & Rows.Count).End(xlUp).Offset(1)).Resize(, Cells(4, Columns.Count).End(xlToLeft).Column)
    nc = .Columns.Count + 1
    a = .Columns(1).Value
    a(1, 1) = a(2, 1)
    ReDim b(1 To UBound(a), 1 To 1)
    b(1, 1) = 1
    dTest = Interval
    For i = 2 To UBound(a)
      If Int(a(i, 1) / dTest) > Int(a(i - 1, 1) / dTest) Then
        b(IIf(Abs(a(i, 1) - dTest) > Abs(a(i - 1, 1) - dTest), i - 1, i), 1) = 1
        dTest = dTest + Interval
      End If
    Next i
    .Columns(nc).Value = b
    Intersect(.EntireColumn, .Columns(nc).SpecialCells(xlConstants).EntireRow).Copy Destination:=Sheets("Sheet4").Range("A1")
    .Columns(nc).ClearContents
  End With



End Sub

Thank you in advance.

Allison

 

[Peter_SSs]

Hello Peter!

Thank you very much, this is exactly what I needed,

OK, great.

will it be possible to also record and paste the first value ? (this is the one close to 0)

So, do you just mean always paste the first row after the headings? That is row 5?

Please see attached the overall code. I'm getting and error Run-time error '13': Type mismatch. Apparently is because I have another variable with the same name but can't find it.

What line gives the error (click Debug when it happens) and what makes you think the problem is a duplicate variable name?

My guess is that the problem line is this one.

If Int(a(i, 1) / dTest) > Int(a(i - 1, 1) / dTest) Then

If so, when you get the error & click Debug, hover directly over each of the highlighted 'a's and see what value is recorded. I'm guessing a text value.
It might give you a clue as to what is going wrong. Could be that the code is operating on the wrong sheet? Remember that the code is designed to run on the active sheet and I'm not sure what that is for you at the time the code gets to this section as I am unable to test due to not having the required other workbooks etc.

 

[Allison1995]

Hi Peter,

Regarding your questions;

1-So, do you just mean always paste the first row after the headings? That is row 5? Yes, atm the macro starts with the first time step (e.g. 10min), will it be possible to consider the first value once it paste it into "sheet4''?

2-What line gives the error (click Debug when it happens) and what makes you think the problem is a duplicate variable name? Apparently fails once it reaches the Next i . I mentioned the duplicate variable name because I google it and that was one of the possible solution (not 100% sure if that is correct)

3-Could be that the code is operating on the wrong sheet? I added a line with Worksheets("Sheet2"). Activate just to make sure is the right one but stills does not work.

Is interesting to see that if I run the full macro (yours and the one I added that creates the different sheets) it gives me the error. However, if I run the full macro, I stop it once it has created "Sheet2", create a new workbook and copy the "Sheet2", then paste your macro, it works.

Is it possible to upload excels files into the post ? .

Thanks again for your patience.
Allison

 

[Peter_SSs]

Is it possible to upload excels files into the post ? .

No, but you could upload simple sample file(s) to a public file-share site (eg Dropbox) and provide share-link(s) in your post.

In the code you posted there is no reason to believe that the variable i is duplicated, and 'Next i' would be a very unusual place for the code to error!

 

[Allison1995]

Hi Peter,

Thanks for feedback.

I still can't get it to work. Please find attache the URL to the dropbox folder;

https://www.dropbox.com/sh/zm8c45377gvmxvz/AAAhlV1hOjkAlSadNXKP6tEMa?dl=0

I've also attached a instruction file with what I'm thinking of archiving.

Allison

 

[Peter_SSs]

.. t you could upload simple sample file(s) ..

Please find attache the URL to the dropbox folder;

They appear to be very large files. Can you make some simple, small ones that demonstrate the issue?